使用多个变量设置数据透视表过滤器

Question

我有一个看起来很讨厌的 VBA，它将创建一个新工作表并根据列表命名该工作表，在该新工作表中创建一个数据透视表，然后将数据透视表过滤为工作表名称。该列表位于 A 列和 B 列中，并且在两列中都包含空白，但代码知道跳过这些空白。

我遇到的问题是，如果工作表名称包含“0000”，那么它将需要使用 B 列中的信息过滤数据透视表，直到下一个空白。 表格的外观：

AR0000RK    
        AR0030RK
        AR0063RK
        AR0082RK
        AR0085RK
        07020850
TX0000TY    
        TX0182TY
        TX0262TY
        07020830
AR0021ZZ    
AR0031ZZ    
AR0057ZZ    
AR0062ZZ    
AR0066ZZ    
AR0078ZZ    
AR0079ZZ    
AR0084ZZ    
TX0019ZZ    
TX0126ZZ    
TX0130ZZ    
TX0210ZZ    
TX0404ZZ    

和代码：

Sub CreatePivotTable()

Application.DisplayAlerts = False

Dim Wb As Workbook
Dim sht As Worksheet
Dim pvtCache As PivotCache
Dim pvt As PivotTable
Dim StartPvt As String
Dim SrcData As String
Dim pvtLastRow As Long
Dim sh As Worksheet
Dim pf As String
Dim pf_Name As String
Dim pf_Field As PivotField
Dim pf_Filter As PivotFilter
Set aSht = ThisWorkbook.Sheets("ARK_E_TEXAS")
lastRow = aSht.Range("ARK_E_TEXAS_LIST").Rows.Count
Set addPivotName = aSht.Range("B2:B" & lastRow)
Set dataRange = aSht.Range("B2:B" & lastRow)


pvtLastRow = ThisWorkbook.Worksheets("RAW Data").Range("A1").CurrentRegion.Rows.Count

'Determine the data range you want to pivot
  SrcData = ThisWorkbook.Worksheets("RAW Data").Range("A1:DU" & pvtLastRow).Address(ReferenceStyle:=xlR1C1)

  Set sht = ActiveSheet

'Where do you want Pivot Table to start?
  StartPvt = sht.Name & "!" & sht.Range("A5").Address(ReferenceStyle:=xlR1C1)

'Create Pivot Cache from Source Data
  Set pvtCache = ActiveWorkbook.PivotCaches.Create( _
    SourceType:=xlDatabase, _
    SourceData:=SrcData)

'Create Pivot table from Pivot Cache
  Set pvt = pvtCache.CreatePivotTable( _
    TableDestination:=StartPvt, _
    TableName:="PivotTable1")
    pvt.ManualUpdate = True

    pvt.AddFields RowFields:=Array( _
    "building_no", "budget_actvty_cd", "cost_elem_cd", "obj_class_cd", "func_cd", "vend_name", "title", "act_no")


'Create calculated Pivot Fields
    pf = "amt"
    pf_Name = "Sum of amt"
    pvt.AddDataField pvt.PivotFields("amt"), pf_Name, xlSum

    pvt.RowAxisLayout xlTabularRow
    pvt.ShowTableStyleRowStripes = True
    pvt.TableStyle2 = "PivotStyleMedium6"


Set pf_Field = sht.PivotTables("PivotTable1").PivotFields("building_no")
    pf_Field.ClearAllFilters

Do Until pf_Field.PivotFilters.Count = 0
    pf_Field.PivotFilters(1).Delete
Loop

    *For Each addPivotName In dataRange
        If InStr("newSheetName", "0000") > 0 Then
        If addPivotName.Value <> "" Then
            Set pf_Filter = pf_Field.PivotFilters.Add(Type:=xlCaptionEquals, Value1:=addPivotName)
        Else
            Set pf_Filter = pf_Field.PivotFilters.Add(Type:=xlCaptionEquals, Value1:=newSheetName)
        End If
        End If

    Next addPivotName*

    pvt.ManualUpdate = False
    Application.DisplayAlerts = True

 End Sub

Answer 1

此解决方案假设如下：

• 这些过程位于将创建数据透视表的同一工作簿中

• Defined Name“ARK_E_TEXAS_LIST”包含所有要创建的工作表和要应用的过滤器，并遵循以下规则：

  • 列A 包含要创建的工作表的名称

  • 列B 包含要应用于每个工作表中的数据透视表的过滤器

  • 该范围将只有一列由行填充

  • 如果列B 为空，则数据透视表将按列“A”过滤

  • 如果A 列为空白，则实际工作表中的数据透视表（即最后一个非空白）将按B 列过滤 • 过滤器将应用于 Pivot Filed “building_no”

• 此解决方案根据列表创建工作表，删除所有现有工作表。

• 它为所有数据透视表创建一个公共数据透视缓存

由于程序中使用的一些资源对 OP 来说可能是新的，请参阅代码中的 cmets 我也建议访问这些页面，但如果您有任何问题，请告诉我。

Option Base Statement, Variables & Constants，Excel Objects，

With Statement, For...Next Statement, For Each...Next Statement,

Range Object (Excel), Select Case Statement

Option Explicit 'Ensure to copy this line
Option Base 1 'Ensure to copy this line

Sub ARK_E_TEXAS_Process_EEM_Test()
Const kPtbDtaFld As String = "amt"
Const kPtbFltr As String = "building_no"
Const kPtbIni As String = "A5"

Dim aPtbRowFld As Variant
aPtbRowFld = Array( _
    "building_no", "budget_actvty_cd", "cost_elem_cd", _
    "obj_class_cd", "func_cd", "vend_name", "title", "act_no")

Dim Wbk As Workbook, Wsh As Worksheet
Dim rPtbSrc As Range, PtbCch As PivotCache
Dim Ptb As PivotTable, PtbFld As PivotField, PtbItm As PivotItem
Dim aWshFltr As Variant, vItm As Variant, b As Byte
Dim blShow As Boolean

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False

    Rem Set Objects
    Set Wbk = ThisWorkbook
    With Wbk
        Rem Set PivotCache
        With .Worksheets("RAW Data")
            Set rPtbSrc = .Range("A1:DU" & .Cells(1).CurrentRegion.Rows.Count)
        End With
        Set PtbCch = .PivotCaches.Create(xlDatabase, rPtbSrc)
        Rem Set Worksheets & Filter Array
        aWshFltr = Ary_WshsFltrs_Set(.Sheets("ARK_E_TEXAS").Range("ARK_E_TEXAS_LIST"))
    End With

    Rem Process Worksheets & Filter Array
    For Each vItm In aWshFltr
        With Wbk
            Rem Delete Worksheet If Present
            On Error Resume Next
            .Sheets(vItm(1)).Delete
            On Error GoTo 0

            Rem Add Worksheet
            Set Wsh = .Sheets.Add(After:=.Sheets(.Sheets.Count))
            Wsh.Name = vItm(1)

            Rem Add Pivot Table
            Set Ptb = PtbCch.CreatePivotTable(Wsh.Range(kPtbIni), "Pt0")
        End With

        With Ptb
            .RowAxisLayout xlTabularRow
            .ShowTableStyleRowStripes = True
            .TableStyle2 = "PivotStyleMedium6"

            Rem Add Row Fields
            .AddFields RowFields:=aPtbRowFld

            Rem Add Data Fields
            .AddDataField .PivotFields(kPtbDtaFld), Function:=xlSum

            Rem Filter PivotTable
            Set PtbFld = .PivotFields(kPtbFltr)
            PtbFld.ClearAllFilters

        End With

        With PtbFld
            Select Case UBound(vItm)
            Case 1
                .PivotFilters.Add Type:=xlCaptionEquals, Value1:=vItm(1)

            Case Else
                For Each PtbItm In .PivotItems
                    blShow = False
                    For b = 2 To UBound(vItm)
                        If PtbItm.SourceName = vItm(b) Then
                            blShow = True
                            Exit For
                    End If: Next
                    PtbItm.Visible = blShow

    Next: End Select: End With: Next

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False

End Sub

它还包括创建包含数据的数组以添加工作表和数据透视表并过滤它们的过程。

Function Ary_WshsFltrs_Set(rWshFltr As Range) As Variant
Dim rCll As Range
Dim aWshFltr() As Variant, aItm() As String
Dim bA As Byte, bI As Byte
    bA = 0: bI = 0
    For Each rCll In rWshFltr.Columns(1).Cells
        With rCll
            If .Value2 <> Empty Then
                bI = 1
                Erase aItm
                ReDim Preserve aItm(bI)
                aItm(bI) = .Value2
                bA = 1 + bA
                ReDim Preserve aWshFltr(bA)
                aWshFltr(bA) = aItm

            Else
                bI = 1 + bI
                ReDim Preserve aItm(bI)
                aItm(bI) = .Offset(0, 1).Value2
                aWshFltr(bA) = aItm

    End If: End With: Next
    Ary_WshsFltrs_Set = aWshFltr
End Function