VB 代码，用于复制数据透视过滤数据 ID 并将其粘贴到匹配的工作表名称中

真假

我有一个包含以下列和值的 Excel 表：

手动分离数据之前的主表：所有年份的工作簿

姓名	项目编号	期间	小时	总成本
一	1001	2019年	100	50000
一	1002	2019年	100	50000
一	1002	2020年	90	70000
乙	1003	2020年	10	30000
乙	1004	2020年	10	30000

数据年度分离后的主表：工作簿 2020

姓名	项目编号	期间	小时	总成本
一	1002	2020年	90	70000
乙	1003	2020年	10	30000
乙	1004	2020年	10	30000

我的 excel 包含 10000 多行这样的。

现在，我做一个数据透视表并在数据透视表的过滤器部分应用项目 ID，并按以下方式排列剩余的 3 列：

按项目ID过滤后的数据透视表列格式如下：

姓名	预订时间	总成本

现在有了这些数据，以下是我实现所需结果的步骤：

按年份分隔工作簿，并根据 ProjectID 号在每个工作簿内创建单独的 excel 工作表。
我根据主表中的所有唯一项目 ID 创建表。工作表的名称是项目 ID（例如 - 我的工作表名称将为 1001、1002、1003 等）
我想根据项目 ID 复制数据透视过滤数据并将其放入相应的工作表名称中。

我已经做了，第 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 复制数据透视数据并将其放入相应的工作表名称中。

例如 - 我的 VB 代码需要过滤项目 ID 1001 的透视数据并复制名为 1001 的工作表中的 A 行。我的代码需要对所有唯一的项目 ID 重复此操作。

我搜索了此类类似的示例，但找不到可以实现此目的的工作代码。

如果有人可以帮助我，那就太好了。

提前致谢。

CDP1802

在工作簿中运行此操作，其中一张名为“Master”的工作表包含 A 到 E 列中的数据。数据透视表和项目工作表将由宏创建。

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

本文收集自互联网，转载请注明来源。

如有侵权，请联系 [email protected] 删除。