Controlling Excel via Access: Runtime 1004 Method 'Intersect of object' Global failed

[DavidAustin]

Hi all,

I am trying to export query to Excel from Access, manipulate it into a pivot table, format the pivot table and then export into a word document...

I have some code that I have made/taken from other places to do so but I come across a runtime error on one line of code (line 66 in the below code section). This error only happens every other time the code is run which I find odd - e.g. first time works fine, second time gets error. The error relates to me trying to change the number format for all of the value cells that are not subtotals/totals.

All help is greatly appreciated!

Sub ExportToWord()
 
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim xlWS As Excel.Worksheet
Dim pt As PivotTable
Dim i As Integer
Dim rng1 As Range
Dim rng2 As Range
Dim ptItem As PivotItem
Dim fileName As String
Dim dataSheet As Worksheet
Dim pivotSheet As Worksheet
Dim pc As PivotCache
Dim x As Integer
Dim WordApp As Word.Application
Dim myDoc As Word.Document
 
'in my sub i have the actual path here but removed just in case ;)
fileName = "\test.xlsx"
 
'export query to excel file
DoCmd.TransferSpreadsheet acExport, , "qryCountThisCross", fileName, True
 
'open excel file
Set xlApp = New Excel.Application
 
With xlApp
    .Visible = True
    Set xlWB = .Workbooks.Open(fileName, , False)
End With
 
Set dataSheet = xlWB.Worksheets(1)
 
'set up pivot table
xlWB.Worksheets.Add(After:=dataSheet).Name = "PivotSheet"
Set pivotSheet = xlWB.Worksheets("PivotSheet")
 
Set pc = xlWB.PivotCaches.Create(xlDatabase, dataSheet.Range("A1:P40"))
Set pt = pc.CreatePivotTable(pivotSheet.Range("A1"), "PivotTable")
 
'edit pivot table layout
Set pt = pivotSheet.PivotTables("PivotTable")
With pt
    With .PivotFields("Service Line")
        .Orientation = xlRowField
        .Position = 1
        .PivotItems("Younger Adult").Position = 1
        .PivotItems("OPMH").Position = 2
        .PivotItems("Rehab").Position = 3
        .PivotItems("Forensic & Specialist").Position = 4
    End With
    With .PivotFields("Location")
        .Orientation = xlRowField
        .Position = 2
    End With
    With .PivotFields("Ward Name")
        .Orientation = xlRowField
        .Position = 3
    End With
    For x = 5 To .PivotFields.Count
        .AddDataField pt.PivotFields(x), .PivotFields(x).Name & " ", xlSum
    Next x
    .AddDataField pt.PivotFields(4), "Total ", xlSum
 
    'the problem section
    'i'm trying to make it so that if a 0 appears in the data section that is not in the subtotals
    'or totals then it should appear in light grey
    For i = 1 To (pt.DataFields.Count - 1)
        Set rng1 = pt.DataFields(i).DataRange
        For Each ptItem In pt.PivotFields("Ward Name").PivotItems
            Set rng2 = ptItem.DataRange.EntireRow
            'Runtime error 1004: Method 'Intersect' of object' _ Global failed
            Intersect(rng1, rng2).NumberFormat = "#,##0;#,##0;[Color15]#,##0"
        Next ptItem
    Next i
 
    .CompactLayoutRowHeader = "Ward by Service Line"
    .DataPivotField.Caption = "Month"
    .PivotFields(1).LayoutBlankLine = True
    .SubtotalLocation xlAtBottom
End With
 
pt.TableRange1.Copy
 
'Create an Instance of MS Word
  On Error Resume Next
 
    'Is MS Word already opened?
      Set WordApp = GetObject(Class:="Word.Application")
 
    'Clear the error between errors
      Err.Clear
 
    'If MS Word is not already open then open MS Word
      If WordApp Is Nothing Then Set WordApp = CreateObject(Class:="Word.Application")
 
    'Handle if the Word Application is not found
      If Err.Number = 429 Then
        MsgBox "Microsoft Word could not be found, aborting."
        GoTo CLEAR_UP
      End If
 
  On Error GoTo 0
 
'Make MS Word Visible and Active
    WordApp.Visible = True
    WordApp.Activate
 
'Create a New Document
    Set myDoc = WordApp.Documents.Add
 
'Copy Excel Table Range
    WordApp.Selection.PasteSpecial , , , , wdPasteOLEObject
 
xlWB.Close False
xlApp.Quit
 
CLEAR_UP:
Set xlWS = Nothing
Set xlWB = Nothing
Set xlApp = Nothing
Set myDoc = Nothing
Set WordApp = Nothing
 
Set pt = Nothing
Set pc = Nothing
Set pivotSheet = Nothing
Set dataSheet = Nothing
Set xlWB = Nothing
 
Set rng2 = Nothing
Set rng1 = Nothing
Set ptItem = Nothing
 
End Sub

[jforbes]

I've not done what you are attempting, but I've done some Cross Office Application VBA development. I looked up the Intersect command on Microsoft's website and there was this example:

Worksheets("Sheet1").Activate 
Set isect = Application.Intersect(Range("rg1"), Range("rg2")) 
If isect Is Nothing Then 
 MsgBox "Ranges do not intersect" 
Else 
 isect.Select 
End If

From their code it looks like the Intersect Method doesn't always return an object. Which means you might want to want to test to see if there is an intersection before setting the Number Format. I didn't look at your code hard enough to see if there will always be an intersection, but this would be the place I would start.

Something like:

Dim oIntersect As Range
...
Set oIntersect = xlApp.Intersect(rng1, rng2) 
If not oIntersect Is Nothing Then 
    oIntersect.NumberFormat = "#,##0;#,##0;[Color15]#,##0"
End If

[DavidAustin]

Hi jforbes,

Thanks for having a look. I would have thought that there would always be an intersection being a pivot table with a format that doesn't change. Anyway, I gave the code a go and it works like a charm. Tested it 5 times in a row with no runtime errors and correct results everytime.

Many thanks!