CODEWITHSUNDEEP
excelvbapivot-table
trueorfalse
trueorfalse

Reputation: 31

VB Code to copy pivot filtered data ID wise and paste it in matching sheet name

I have an excel sheet with following columns and values:

Master sheet before segregation of data year wise manually: Workbook for all years

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

Master sheet after segregation of data year wise: Workbook 2020

Name Project ID Period Hours Total Cost
A 1002 2020 90 70000
B 1003 2020 10 30000
B 1004 2020 10 30000

My excel contains 10000 plus lines like this.

Now, I do a pivot and apply Project ID in the filter section of pivot and arrange the 3 remaining columns in the following manner:

Pivot sheet Column format after filtering it by project ID is as follows:

Name Hours booked Total Cost

Now with this data, following are my steps to achieve needed result:

  1. Segregation of workbooks by year and creation of separate excel worksheets inside each workbook based on ProjectID number.
  2. I create sheets based on all unique project IDs I have in master sheet. With name of the sheet being project ID (Example - My sheet name will be 1001, 1002, 1003, etc)
  3. I would like to copy the pivot filtered data according to project ID and put it in corresponding sheet names.

I already did, Step 1. Manually with help of data filters option in excel, Step 2. with a VB code below:

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

This is where I need help with the code, Step 3 - I would like to copy the pivot data according to project ID and put it in corresponding sheet names.

For example- My VB code needs to filter pivot data for Project ID 1001 and copy the row A in sheet named 1001. And my code needs to repeat this for all unique project IDs.

I searched for such similar examples but I could not find a working code to achieve this.

If anyone could help me with this it would be nice.

Thanks in advance.

Upvotes: 1

Views: 244

Answers (1)

CDP1802
CDP1802

Reputation: 16174

Run this in a workbook with one sheet called "Master" containing your data in columns A to E. The pivot table and project sheets will be created by the macro.

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

Upvotes: 1

Related Questions