I have a challenge... I have a range in Sheet Lookup with each possible value in Pivot table filter "Owner: Full Name".
我有一个挑战...我在Sheet Lookup中有一个范围,其中每个可能的值都在数据透视表过滤器“Owner:Full Name”中。
The range with the names are Sheets "Lookup" Range B2:B98. (Problem 1: This range can change as it creates this list in a different code, how to set this to a dynamic range?)
名称范围是Sheets“Lookup”Range B2:B98。 (问题1:此范围可以更改,因为它在不同的代码中创建此列表,如何将其设置为动态范围?)
Once it filters on that i.e. value in B2 it should copy this filtered pivot into a new sheet and name the sheet after the value in b2.
一旦它过滤了B2中的那个值,它应该将这个过滤的枢轴复制到一个新的工作表中,并将该工作表命名为b2中的值。
Then it should "deselect" the b2 item and go to filter on value in b3 and continue.
然后它应该“取消选择”b2项目并继续过滤b3中的值并继续。
Problem 2: Setting the filter correctly to loop and filter on each single value in the new dynamic lookup range.
问题2:正确设置过滤器以循环并过滤新动态查找范围中的每个单独值。
Here is what I have at the moment...
这就是我现在所拥有的......
Option Explicit
Dim wb As Workbook, ws, ws1, ws2 As Worksheet, PT As PivotTable, PTI As
PivotItem, PTF As PivotField, rng As Range
Sub Filter_Pivot()
Set wb = ThisWorkbook
Set ws = wb.Sheets("Copy")
Set ws1 = wb.Sheets("Lookup")
Set PT = ws.PivotTables("PivotCopy")
Set PTF = PT.PivotFields("Owner: Full Name")
For Each rng In ws1.Range("B2:B98")
With PTF
.ClearAllFilters
For Each PTI In PTF.PivotItems
PTI.Visible = (PTI.Name = rng)
Next PTI
Set ws2 = Sheets.Add
ws1.Name = PTI
.TableRange2.Copy
ws2.Range("A1").PasteSpecial
End With
Next rng
End Sub
2 个解决方案
#1
2
You might be able to avoid all this and use the PivotTable.ShowPages Method
. It is optimized for this sort of operation.
您可以避免所有这些并使用PivotTable.ShowPages方法。它针对此类操作进行了优化。
Note:
-
"Owner: Full Name"
must be in the page field area at the top. - You probably want to check the sheet names don't already exist. You could do an initial loop of sheet names that will be generated from pivot and try deleting them (wrapping inside an
On Error Resume Next, attempt delete, On Error GoTo 0
) to ensure they don't exist first. I have shown how to do this in the second example.
“所有者:全名”必须位于顶部的页面字段区域中。
您可能想要检查工作表名称是否尚不存在。您可以执行将从pivot生成的工作表名称的初始循环并尝试删除它们(包含在On Error Resume Next,尝试删除,On Error GoTo 0)以确保它们不存在。我在第二个例子中展示了如何做到这一点。
Info: PivotTable.ShowPages Method
信息:PivotTable.ShowPages方法
Creates a new PivotTable report for each item in the page field. Each new report is created on a new worksheet.
为页面字段中的每个项目创建新的数据透视表。每个新报告都在新工作表上创建。
Syntax expression . ShowPages( PageField )
语法表达式。 ShowPages(PageField)
expression A variable that represents a PivotTable object.
expression表示数据透视表对象的变量。
[Optional parameter of pageField.]
[pageField的可选参数。]
Code:
ThisWorkbook.Worksheets("Copy").PivotTables("PivotCopy").ShowPages "Owner: Full Name"
This will produce a sheet for each possible value in the page field "Owner: Full Name"
. If you don't want all of them, simply hold a list of sheet names for sheets to keep, in an array, and loop over all sheets in workbook and if not in array then delete as shown below:
这将在页面字段“Owner:Full Name”中为每个可能的值生成一个工作表。如果您不想要所有这些,只需保存要保留的工作表的工作表名称列表,在数组中,并循环工作簿中的所有工作表,如果不在数组中,则删除如下所示:
① Example of looping sheets and deleting if not in array:
Option Explicit
Public Sub GeneratePivots()
Dim keepSheets(), ws As Worksheet
keepSheets = Array("FilterValue1", "FilterValue2","Lookup","Copy") '<== List of sheet names to keep
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error GoTo errHand
ThisWorkbook.Worksheets("Copy").PivotTables("PivotCopy").ShowPages "Owner: Full Name"
For Each ws In ThisWorkbook.Worksheets
If IsError(Application.Match(ws.Name, keepSheets, 0)) And ThisWorkbook.Worksheets.Count > 1 Then
ws.Delete
End If
Next ws
errHand:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
② Using a lookup sheet:
If you do want to still read in the sheets to keep from the Copy
sheet then you can use the following (but be sure to include in the list in column B the sheet names Copy
,Lookup
, the filter values of interest, and any other sheet names you don't want deleted):
如果您确实仍希望读取工作表以保留复制工作表,则可以使用以下内容(但请确保在B列的列表中包含工作表名称复制,查找,感兴趣的过滤器值以及任何其他您不想删除的工作表名称):
Code:
Option Explicit
Public Sub GeneratePivots()
Dim ws As Worksheet, lookups As Range
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With ThisWorkbook.Worksheets("Lookup")
Set lookups = .Range(.Range("B2"), .Range("B2").End(xlDown))
If Application.WorksheetFunction.CountA(lookups) = 0 Then Exit Sub
keepSheets = lookups.Value
End With
Dim rng As Range
For Each rng In lookups
On Error Resume Next
Select Case rng.Value
Case "Lookup", "Copy" '<=Extend for sheets to keep listed in lookups that aren't generated by the pivot filtering
Case Else
ThisWorkbook.Worksheets(rng.Value).Delete
End Select
On Error GoTo 0
Next rng
On Error GoTo errHand
ThisWorkbook.Worksheets("Copy").PivotTables("PivotCopy").ShowPages "Owner: Full Name"
For Each ws In ThisWorkbook.Worksheets
If IsError(Application.Match(ws.Name, Application.WorksheetFunction.Index(keepSheets, 0, 1), 0)) And ThisWorkbook.Worksheets.Count > 1 Then
ws.Delete
End If
Next ws
errHand:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Example run:
#2
1
You may try something like this...
你可以试试这样的......
Sub Filter_Pivot()
Dim wb As Workbook
Dim ws As Worksheet, ws1 As Worksheet, ws2 As Worksheet
Dim PT As PivotTable
Dim PTF As PivotField
Dim rng As Range
Dim lr As Long
Set wb = ThisWorkbook
Set ws = wb.Sheets("Copy")
Set ws1 = wb.Sheets("Lookup")
Set PT = ws.PivotTables("PivotCopy")
Set PTF = PT.PivotFields("Owner: Full Name")
lr = ws1.Cells(Rows.Count, 2).End(xlUp).Row
For Each rng In ws1.Range("B2:B" & lr)
PTF.ClearAllFilters
On Error Resume Next
PTF.CurrentPage = rng.Value
If Err = 0 Then
Set ws2 = Sheets(rng.Value)
ws2.Cells.Clear
If ws2 Is Nothing Then
Set ws2 = Sheets.Add
ws2.Name = rng.Value
End If
PT.TableRange2.Copy ws2.Range("A1")
End If
PTF.ClearAllFilters
Set ws2 = Nothing
On Error GoTo 0
Next rng
End Sub
#1
2
You might be able to avoid all this and use the PivotTable.ShowPages Method
. It is optimized for this sort of operation.
您可以避免所有这些并使用PivotTable.ShowPages方法。它针对此类操作进行了优化。
Note:
-
"Owner: Full Name"
must be in the page field area at the top. - You probably want to check the sheet names don't already exist. You could do an initial loop of sheet names that will be generated from pivot and try deleting them (wrapping inside an
On Error Resume Next, attempt delete, On Error GoTo 0
) to ensure they don't exist first. I have shown how to do this in the second example.
“所有者:全名”必须位于顶部的页面字段区域中。
您可能想要检查工作表名称是否尚不存在。您可以执行将从pivot生成的工作表名称的初始循环并尝试删除它们(包含在On Error Resume Next,尝试删除,On Error GoTo 0)以确保它们不存在。我在第二个例子中展示了如何做到这一点。
Info: PivotTable.ShowPages Method
信息:PivotTable.ShowPages方法
Creates a new PivotTable report for each item in the page field. Each new report is created on a new worksheet.
为页面字段中的每个项目创建新的数据透视表。每个新报告都在新工作表上创建。
Syntax expression . ShowPages( PageField )
语法表达式。 ShowPages(PageField)
expression A variable that represents a PivotTable object.
expression表示数据透视表对象的变量。
[Optional parameter of pageField.]
[pageField的可选参数。]
Code:
ThisWorkbook.Worksheets("Copy").PivotTables("PivotCopy").ShowPages "Owner: Full Name"
This will produce a sheet for each possible value in the page field "Owner: Full Name"
. If you don't want all of them, simply hold a list of sheet names for sheets to keep, in an array, and loop over all sheets in workbook and if not in array then delete as shown below:
这将在页面字段“Owner:Full Name”中为每个可能的值生成一个工作表。如果您不想要所有这些,只需保存要保留的工作表的工作表名称列表,在数组中,并循环工作簿中的所有工作表,如果不在数组中,则删除如下所示:
① Example of looping sheets and deleting if not in array:
Option Explicit
Public Sub GeneratePivots()
Dim keepSheets(), ws As Worksheet
keepSheets = Array("FilterValue1", "FilterValue2","Lookup","Copy") '<== List of sheet names to keep
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error GoTo errHand
ThisWorkbook.Worksheets("Copy").PivotTables("PivotCopy").ShowPages "Owner: Full Name"
For Each ws In ThisWorkbook.Worksheets
If IsError(Application.Match(ws.Name, keepSheets, 0)) And ThisWorkbook.Worksheets.Count > 1 Then
ws.Delete
End If
Next ws
errHand:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
② Using a lookup sheet:
If you do want to still read in the sheets to keep from the Copy
sheet then you can use the following (but be sure to include in the list in column B the sheet names Copy
,Lookup
, the filter values of interest, and any other sheet names you don't want deleted):
如果您确实仍希望读取工作表以保留复制工作表,则可以使用以下内容(但请确保在B列的列表中包含工作表名称复制,查找,感兴趣的过滤器值以及任何其他您不想删除的工作表名称):
Code:
Option Explicit
Public Sub GeneratePivots()
Dim ws As Worksheet, lookups As Range
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With ThisWorkbook.Worksheets("Lookup")
Set lookups = .Range(.Range("B2"), .Range("B2").End(xlDown))
If Application.WorksheetFunction.CountA(lookups) = 0 Then Exit Sub
keepSheets = lookups.Value
End With
Dim rng As Range
For Each rng In lookups
On Error Resume Next
Select Case rng.Value
Case "Lookup", "Copy" '<=Extend for sheets to keep listed in lookups that aren't generated by the pivot filtering
Case Else
ThisWorkbook.Worksheets(rng.Value).Delete
End Select
On Error GoTo 0
Next rng
On Error GoTo errHand
ThisWorkbook.Worksheets("Copy").PivotTables("PivotCopy").ShowPages "Owner: Full Name"
For Each ws In ThisWorkbook.Worksheets
If IsError(Application.Match(ws.Name, Application.WorksheetFunction.Index(keepSheets, 0, 1), 0)) And ThisWorkbook.Worksheets.Count > 1 Then
ws.Delete
End If
Next ws
errHand:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Example run:
#2
1
You may try something like this...
你可以试试这样的......
Sub Filter_Pivot()
Dim wb As Workbook
Dim ws As Worksheet, ws1 As Worksheet, ws2 As Worksheet
Dim PT As PivotTable
Dim PTF As PivotField
Dim rng As Range
Dim lr As Long
Set wb = ThisWorkbook
Set ws = wb.Sheets("Copy")
Set ws1 = wb.Sheets("Lookup")
Set PT = ws.PivotTables("PivotCopy")
Set PTF = PT.PivotFields("Owner: Full Name")
lr = ws1.Cells(Rows.Count, 2).End(xlUp).Row
For Each rng In ws1.Range("B2:B" & lr)
PTF.ClearAllFilters
On Error Resume Next
PTF.CurrentPage = rng.Value
If Err = 0 Then
Set ws2 = Sheets(rng.Value)
ws2.Cells.Clear
If ws2 Is Nothing Then
Set ws2 = Sheets.Add
ws2.Name = rng.Value
End If
PT.TableRange2.Copy ws2.Range("A1")
End If
PTF.ClearAllFilters
Set ws2 = Nothing
On Error GoTo 0
Next rng
End Sub