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

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列过滤•过滤器将应用于数据透视字段“ building_no”

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

• 它为所有数据透视表创建一个通用的数据透视缓存

由于该过程中使用的某些资源可能不是OP的新增功能，因此我也建议您访问这些页面中的注释，不过请告诉我您可能遇到的任何问题。

选项基本语句 ， 变量和常量 ， Excel对象 ，

带有Statement ， For ... Next语句 ， For Each ... Next Statement ，

范围对象（Excel） ， 选择案例陈述

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