作者：绿色风
分类：
时间：2022-08-17
浏览：136
楼主
水星钓鱼 |
Q：如何借助数据透视表的报表筛选功能拆分工作表？
A：以下代码借助了数据透视表的“报表筛选页”功能拆分工作表。- Sub xyf()
- On Error Resume Next
- Dim oPC As PivotCache
- Dim oPT As PivotTable
- Dim oPF As PivotField
- Dim oPI As PivotItem
- Dim oWk As Worksheet
- Dim oRng As Range
- Dim sRng As String
- Dim sFieldName As String
- Application.DisplayAlerts = False
- For Each oWk In Application.Worksheets
- If oWk.Name <> Me.Name Then
- oWk.Visible = xlSheetVisible
- oWk.Delete
- End If
- Next
- Set oRng = Application.InputBox(prompt:="请你选择要根据哪个字段拆分销售汇总表?", Title:="拆分总表", Type:=8)
- If Err.Number = 424 Then
- Exit Sub
- End If
- sRng = oRng.CurrentRegion.Address(False, False, xlA1, True)
- If oRng.Columns.Count = 1 Then
- sFieldName = oRng.End(xlUp).Value
- Else
- MsgBox "你选择的字段不适合用来拆分总表，请重新选择!"
- Exit Sub
- End If
- Set oWk = ThisWorkbook.Worksheets.Add
- Set oPT = ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=sRng).CreatePivotTable(TableDestination:=oWk.Range("A1"))
- Set oPF = oPT.PivotFields(sFieldName)
- oPF.Orientation = xlPageField
- oPT.ShowPages oPF
- oWk.Visible = xlSheetVeryHidden
- For Each oPI In oPF.PivotItems
- Set oWk = ThisWorkbook.Worksheets(oPI.Caption)
- Set oPT = oWk.PivotTables(1)
- With oPT
- .RowAxisLayout xlTabularRow
- .RepeatAllLabels xlRepeatLabels
- .ColumnGrand = False
- .RowGrand = False
- .ShowDrillIndicators = False
- .EnableFieldList = False
- .EnableWizard = False
- For Each oPF In .PivotFields
- With oPF
- .Orientation = xlRowField
- .Subtotals(1) = False
- End With
- Next
- .PivotFields(sFieldName).PivotFilters.Add Type:=xlCaptionEquals, Value1:=oPI.Caption
- For Each oPF In .PivotFields
- oPF.EnableItemSelection = False
- Next
- End With
- oWk.Rows("1:2").Delete
- oWk.Columns.AutoFit
- Next
- Set oWk = Nothing
- Set oRng = Nothing
- Application.DisplayAlerts = True
- End Sub
附件如下：
 利用数据透视表的报表筛选功能拆分字段.rar
|
2楼
eliane_lei |
 跟着楼主好好学习！ |
3楼
老糊涂 |
|
免责声明
有感于原ExcelTip.Net留存知识的价值及部分知识具有的时间限定性因素，
经与ExcelTip.Net站长Apolloh商议并征得其同意，
现将原属ExcelTip.Net的知识帖采集资料于本站点进行展示，
供有需要的人士查询使用，也慰缅曾经的论坛时代。
所示各个帖子的原作者如对版权有异议，
可与本人沟通提出，或于本站点留言，我们会尽快处理。
在此，感谢ExcelTip.Net站长Apolloh的支持，感谢本站点所有人**绿色风（QQ:79664738)**的支持与奉献，特此鸣谢！
------本人网名**KevinChengCW（QQ:1210618015)**原ExcelTip.Net总版主之一