时间戳

首页 > 解决方案 > VB代码以复制数据透视过滤数据ID并将其粘贴到匹配的工作表名称中

excel - 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过滤后的列格式如下：

姓名 预订时间 总消耗

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

  1. 按年份分隔工作簿，并根据 ProjectID 编号在每个工作簿内创建单独的 Excel 工作表。
  2. 我根据我在主工作表中拥有的所有唯一项目 ID 创建工作表。工作表名称为项目 ID（例如 - 我的工作表名称为 1001、1002、1003 等）
  3. 我想根据项目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 重复此操作。

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

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

提前致谢。

标签： excelvbapivot-table

解决方案

在一个名为“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

推荐阅读