VB 代码以明智地复制数据透视过滤数据 ID 并将其粘贴到匹配的 sheet 名称中
VB Code to copy pivot filtered data ID wise and paste it in matching sheet name
我有一个 excel sheet 包含以下列和值:
掌握 sheet 在数据年度分离之前手动:所有年份的工作簿
Name
Project ID
Period
Hours
Total Cost
A
1001
2019
100
50000
A
1002
2019
100
50000
A
1002
2020
90
70000
B
1003
2020
10
30000
B
1004
2020
10
30000
大师 sheet 数据年度分离后:工作簿 2020
Name
Project ID
Period
Hours
Total Cost
A
1002
2020
90
70000
B
1003
2020
10
30000
B
1004
2020
10
30000
我的 excel 包含 10000 多行这样的内容。
现在,我做一个数据透视表并在数据透视表的过滤器部分应用项目 ID,并按以下方式排列剩余的 3 列:
Pivot sheet按项目ID过滤后的列格式如下:
Name
Hours booked
Total Cost
现在有了这些数据,以下是我实现所需结果的步骤:
- 按年份划分工作簿并根据 ProjectID 编号在每个工作簿中创建单独的 excel 工作sheet。
- 我根据我在 master sheet 中拥有的所有唯一项目 ID 创建 sheets。 sheet 的名称是项目 ID(示例 - 我的 sheet 名称将是 1001、1002、1003 等)
- 我想根据项目ID复制pivot过滤后的数据,放到对应的sheet名字里。
我已经做了,
第 1 步。在 excel 中的数据过滤器选项的帮助下手动操作,
第 2 步。使用下面的 VB 代码:
Sub AddSheets()
'Updateby Extendoffice
Dim xRg As Excel.Range
Dim wSh As Excel.Worksheet
Dim wBk As Excel.Workbook
Set wSh = ActiveSheet
Set wBk = ActiveWorkbook
Application.ScreenUpdating = False
For Each xRg In wSh.Range("A1:A93")
With wBk
.Sheets.Add After:=.Sheets(.Sheets.Count)
On Error Resume Next
ActiveSheet.Name = xRg.Value
If Err.Number = 1004 Then
Debug.Print xRg.Value & " already used as a sheet name"
End If
On Error GoTo 0
End With
Next xRg
Application.ScreenUpdating = True
End Sub
这是我需要代码帮助的地方,
第 3 步 - 我想根据项目 ID 复制数据透视表并将其放入相应的 sheet 名称中。
例如-我的 VB 代码需要过滤项目 ID 1001 的数据透视表并复制 sheet 中名为 1001 的行 A。我的代码需要对所有唯一项目 ID 重复此操作.
我搜索了类似的示例,但找不到实现此目的的工作代码。
如果有人能帮助我,那就太好了。
提前致谢。
运行 这在一个工作簿中,其中有一个 sheet 称为“Master”,其中包含 A 到 E 列中的数据。数据透视表 table 和项目 sheets 将由宏创建。
Option Explicit
Sub macro()
Const SHT_MASTER = "Master"
Const SHT_PIVOT = "PivotdataOfMasterSheet"
Const COL_ID = "B" ' project id
Const PERIOD = 2020
Dim wb As Workbook
Dim ws As Worksheet, wsPivot As Worksheet, wsPrj As Worksheet
Dim iLastRow As Long, iRow As Long, n As Integer
Dim rng As Range, tbl As PivotTable
Set wb = ThisWorkbook
' check if any existing sheets and delete
For Each ws In wb.Sheets
If ws.Name = SHT_MASTER Then
Else
ws.Delete
End If
Next
Set ws = wb.Sheets(SHT_MASTER)
iLastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
' build list of projects
Dim dict As Object, key
Set dict = CreateObject("Scripting.Dictionary")
For iRow = 2 To iLastRow
key = Trim(ws.Cells(iRow, COL_ID))
If Not dict.exists(key) Then
dict(key) = 1
End If
Next
' pivot range
Set rng = ws.Range("A1").Resize(iLastRow, 5) ' col A to E
' create pivot on neq sheet
Set wsPivot = wb.Sheets.Add
wsPivot.Name = SHT_PIVOT
wb.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=rng, _
Version:=xlPivotTableVersion14).CreatePivotTable _
TableDestination:=wsPivot.Range("A3"), TableName:="PivotTable", DefaultVersion _
:=xlPivotTableVersion14
Set tbl = wsPivot.PivotTables("PivotTable")
With tbl
.AddDataField ActiveSheet.PivotTables( _
"PivotTable").PivotFields("Hours"), "Sum of Hours", xlSum
.AddDataField ActiveSheet.PivotTables( _
"PivotTable").PivotFields("Total Cost"), "Sum of Total Cost", xlSum
With .PivotFields("Name")
.Orientation = xlRowField
.Position = 1
End With
With .PivotFields("Period")
.Orientation = xlPageField
.Position = 1
End With
With .PivotFields("Project ID")
.Orientation = xlPageField
.Position = 1
End With
.PivotFields("Project ID").ClearAllFilters
.PivotFields("Period").ClearAllFilters
.PivotFields("Period").CurrentPage = PERIOD
End With
' create sheet for each project
n = wb.Sheets.Count
For Each key In dict
tbl.PivotFields("Project ID").CurrentPage = key
Set wsPrj = wb.Sheets.Add(After:=wb.Sheets(n))
wsPrj.Name = key
n = n + 1
wsPivot.UsedRange.Copy
wsPrj.Range("A1").PasteSpecial xlPasteValues
Application.CutCopyMode = False
wsPrj.Columns("A:C").AutoFit
Next
MsgBox dict.Count & " sheets created", vbInformation
End Sub
我有一个 excel sheet 包含以下列和值:
掌握 sheet 在数据年度分离之前手动:所有年份的工作簿
Name | Project ID | Period | Hours | Total Cost |
---|---|---|---|---|
A | 1001 | 2019 | 100 | 50000 |
A | 1002 | 2019 | 100 | 50000 |
A | 1002 | 2020 | 90 | 70000 |
B | 1003 | 2020 | 10 | 30000 |
B | 1004 | 2020 | 10 | 30000 |
大师 sheet 数据年度分离后:工作簿 2020
Name | Project ID | Period | Hours | Total Cost |
---|---|---|---|---|
A | 1002 | 2020 | 90 | 70000 |
B | 1003 | 2020 | 10 | 30000 |
B | 1004 | 2020 | 10 | 30000 |
我的 excel 包含 10000 多行这样的内容。
现在,我做一个数据透视表并在数据透视表的过滤器部分应用项目 ID,并按以下方式排列剩余的 3 列:
Pivot sheet按项目ID过滤后的列格式如下:
Name | Hours booked | Total Cost |
---|
现在有了这些数据,以下是我实现所需结果的步骤:
- 按年份划分工作簿并根据 ProjectID 编号在每个工作簿中创建单独的 excel 工作sheet。
- 我根据我在 master sheet 中拥有的所有唯一项目 ID 创建 sheets。 sheet 的名称是项目 ID(示例 - 我的 sheet 名称将是 1001、1002、1003 等)
- 我想根据项目ID复制pivot过滤后的数据,放到对应的sheet名字里。
我已经做了, 第 1 步。在 excel 中的数据过滤器选项的帮助下手动操作, 第 2 步。使用下面的 VB 代码:
Sub AddSheets()
'Updateby Extendoffice
Dim xRg As Excel.Range
Dim wSh As Excel.Worksheet
Dim wBk As Excel.Workbook
Set wSh = ActiveSheet
Set wBk = ActiveWorkbook
Application.ScreenUpdating = False
For Each xRg In wSh.Range("A1:A93")
With wBk
.Sheets.Add After:=.Sheets(.Sheets.Count)
On Error Resume Next
ActiveSheet.Name = xRg.Value
If Err.Number = 1004 Then
Debug.Print xRg.Value & " already used as a sheet name"
End If
On Error GoTo 0
End With
Next xRg
Application.ScreenUpdating = True
End Sub
这是我需要代码帮助的地方, 第 3 步 - 我想根据项目 ID 复制数据透视表并将其放入相应的 sheet 名称中。
例如-我的 VB 代码需要过滤项目 ID 1001 的数据透视表并复制 sheet 中名为 1001 的行 A。我的代码需要对所有唯一项目 ID 重复此操作.
我搜索了类似的示例,但找不到实现此目的的工作代码。
如果有人能帮助我,那就太好了。
提前致谢。
运行 这在一个工作簿中,其中有一个 sheet 称为“Master”,其中包含 A 到 E 列中的数据。数据透视表 table 和项目 sheets 将由宏创建。
Option Explicit
Sub macro()
Const SHT_MASTER = "Master"
Const SHT_PIVOT = "PivotdataOfMasterSheet"
Const COL_ID = "B" ' project id
Const PERIOD = 2020
Dim wb As Workbook
Dim ws As Worksheet, wsPivot As Worksheet, wsPrj As Worksheet
Dim iLastRow As Long, iRow As Long, n As Integer
Dim rng As Range, tbl As PivotTable
Set wb = ThisWorkbook
' check if any existing sheets and delete
For Each ws In wb.Sheets
If ws.Name = SHT_MASTER Then
Else
ws.Delete
End If
Next
Set ws = wb.Sheets(SHT_MASTER)
iLastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
' build list of projects
Dim dict As Object, key
Set dict = CreateObject("Scripting.Dictionary")
For iRow = 2 To iLastRow
key = Trim(ws.Cells(iRow, COL_ID))
If Not dict.exists(key) Then
dict(key) = 1
End If
Next
' pivot range
Set rng = ws.Range("A1").Resize(iLastRow, 5) ' col A to E
' create pivot on neq sheet
Set wsPivot = wb.Sheets.Add
wsPivot.Name = SHT_PIVOT
wb.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=rng, _
Version:=xlPivotTableVersion14).CreatePivotTable _
TableDestination:=wsPivot.Range("A3"), TableName:="PivotTable", DefaultVersion _
:=xlPivotTableVersion14
Set tbl = wsPivot.PivotTables("PivotTable")
With tbl
.AddDataField ActiveSheet.PivotTables( _
"PivotTable").PivotFields("Hours"), "Sum of Hours", xlSum
.AddDataField ActiveSheet.PivotTables( _
"PivotTable").PivotFields("Total Cost"), "Sum of Total Cost", xlSum
With .PivotFields("Name")
.Orientation = xlRowField
.Position = 1
End With
With .PivotFields("Period")
.Orientation = xlPageField
.Position = 1
End With
With .PivotFields("Project ID")
.Orientation = xlPageField
.Position = 1
End With
.PivotFields("Project ID").ClearAllFilters
.PivotFields("Period").ClearAllFilters
.PivotFields("Period").CurrentPage = PERIOD
End With
' create sheet for each project
n = wb.Sheets.Count
For Each key In dict
tbl.PivotFields("Project ID").CurrentPage = key
Set wsPrj = wb.Sheets.Add(After:=wb.Sheets(n))
wsPrj.Name = key
n = n + 1
wsPivot.UsedRange.Copy
wsPrj.Range("A1").PasteSpecial xlPasteValues
Application.CutCopyMode = False
wsPrj.Columns("A:C").AutoFit
Next
MsgBox dict.Count & " sheets created", vbInformation
End Sub