我有一个非常讨厌的VBA，它将创建一个新工作表，并根据列表命名该工作表，在该新工作表中创建数据透视表，然后将数据透视表过滤到工作表名称。该列表位于A＆amp;列中。 B并且在两列中都包含空格，但代码知道跳过这些空白。
我遇到的问题是，如果工作表名称包含＆＃34; 0000＆＃34;然后它需要使用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
答案 0 :(得分：0)
此解决方案假设如下：
Defined Name＆＃34; ARK_E_TEXAS_LIST＆＃34;保存要创建的所有工作表和要应用的过滤器，并遵循以下规则：
•列A包含要创建的工作表的名称
•列B包含要应用于每个工作表中的数据透视表的过滤器
•范围只有一行填充
•如果列B为空，则数据透视表将按列“A
•如果列A为空白，则实际工作表中的数据透视表（即最后一个非空白）将按列B进行过滤
•过滤器将应用于Pivot Filed“building_no”
此解决方案根据列表创建工作表，删除任何现有工作表。
由于程序中使用的某些资源可能是OP的新功能，请参阅代码中的注释，我建议访问这些页面，但请告诉我您可能遇到的任何问题。
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