Using MSAccess to remotely Pivot Filter and copy results to another tab (Automation) (1 Viewer)

Rx_

Nothing In Moderation
Local time
Today, 17:46
Joined
Oct 22, 2009
Messages
2,803
Any additional ideas on setting filters in an Excel Pivot Table?

Also: Found TableRange2.Address - are there any other features for what seems to be an undocumented Excel object?

The vba running from MSAccess to automate Excel objects:
The ActiveSheet.PivotTables("myPivotTable").PivotFields("Foo").currentpage = "2014"
Just would not work. A few web site post indicated it was troublesome.

After some searching, the following code did work.
ObjXL is an object set to the Excel.Application
This code segment is successfully run from MSAccess (with a reference set to Excel in Tool Options code module).

Pay close attention to the
PivotRange = .ActiveSheet.PivotTables("PivotTable2").TableRange2.Address

Found TableRange2.Address selects the visible rows in a Pivot and returns the range. It did not show up in the F2 Object browser... but works.

Code:
 '************************************************
' Populate Inv Iss Template tab (not really an Excel template, just the name of a tab)
'objxl.ActiveSheet.PivotTables("PivotTable2").tablerange2.Address
' Tablerange2 is not listed in Object browser - but returns visible rows after filter
' Set pf = ActiveSheet.PivotTables("PivotTable2").PivotFields("Fiscal_Year")
'Clear Out Any Previous Filtering
 ' pf.ClearAllFilters
'************************************************
    Dim RowCount As Long
    Dim PivotRange As String
    Dim FirstCopyRecordCount As Long    ' The count of first Past records with Projects
    Dim SecondCopyRecordCount As Long  ' The count of NoProj
    Dim ThirdCopyRecoordCount As Long   'count of the special situations
    
   ' ****************************************
   ' first level Iss Pivot copy Pasted Projects assigned
   ' ****************************************
    .Sheets("Inv Iss Pivot").Select
    With .ActiveSheet.PivotTables("PivotTable2").PivotFields("Project Number")
        .PivotItems("NO PROJ").Visible = False
        .PivotItems("(blank)").Visible = False
    End With
    PivotRange = .ActiveSheet.PivotTables("PivotTable2").TableRange2.Address
    ' Can't be blank because it includes the last Totals row
    .Range(PivotRange).Select ' NEED to find Last record here see tablerange2
    RowCount = .Selection.Rows.Count
    ' if total is all (count =2 header and total rows) then there is nothing to paste into next worksheet
    If RowCount < 3 Then
        ' exit criteria here - there is nothing to copy
        FirstCopyRecordCount = 0 ' there won't be records, so next copy paste uses this location
    Else
    FirstCopyRecordCount = RowCount ' keep this for 2nd location to paste
    .Range("A4:E" & (RowCount + 1)).Select ' start at row 4 subtract header/Total
    .Application.CutCopyMode = False
    .Selection.Copy
    .Sheets("Inv Iss Template").Select
    .Range("C2").Select
    .Selection.PasteSpecial Paste:=xlPasteFormulasAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    End If
   ' ****************************************
   ' Second level Iss Pivot copy Pasted NO Proj
   ' ****************************************
    .Sheets("Inv Iss Pivot").Select
    .ActiveSheet.PivotTables("PivotTable2").PivotFields("Project Number").ClearAllFilters
    .ActiveSheet.PivotTables("PivotTable2").PivotFields("Project Number").PivotFilters.Add Type:=xlCaptionEquals, Value1:="No PROJ"
    
    'With .ActiveSheet.PivotTables("PivotTable2").PivotFields("Project Number")
        '.PivotItems("NO PROJ").Visible = True
        '.PivotItems("(blank)").Visible = False
    'End With
    PivotRange = .ActiveSheet.PivotTables("PivotTable2").TableRange2.Address
    ' Can't be blank because it includes the last Totals row
    .Range(PivotRange).Select ' NEED to find Last record here see tablerange2
    RowCount = .Selection.Rows.Count
    'Debug.Print "2nd Pivot No Proj"
    ' if total is all (count =2 header and total rows) then there is nothing to paste into next worksheet
    If RowCount < 3 Then
        ' exit criteria here - there is nothing to copy
        SecondCopyRecordCount = 0 ' there won't be records, so next copy paste uses this location
    Else
        SecondCopyRecordCount = RowCount ' keep this for 2nd location to paste
        .Range("A4:E" & (RowCount + 1)).Select ' start at row 4 subtract header/Total
        .Application.CutCopyMode = False
        .Selection.Copy
        .ActiveSheet.PivotTables("PivotTable2").PivotFields("Project Number").ClearAllFilters ' **** Clear all Pivot filters
        .Sheets("Inv Iss Template").Select
        .Range("C" & FirstCopyRecordCount + 3).Select
        '.Range("C2").Select ' first range count
        .Selection.PasteSpecial Paste:=xlPasteFormulasAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        ' This seemed to work!
     End If
 

Users who are viewing this thread

Top Bottom