VBA: Pivot Table

[chaddres]

I need to create a Pivot Table using VBA. I attached a picture of sample data and the desired output. My actual spreadsheet has 40 columns but a variable number of rows.

Filter: Position Status = Active
Rows: Location Code & Home Department Code

That is the entire Pivot Table I need.

 

[smozgur]

Please try the following code. It assumes that your data starts from active sheet's A1 cell. Otherwise the rng object should be set accordingly.
The code is also setting the Position Status filter as Active.

The pivot table is created in a new worksheet.

Sub createPivotTableFromRange()
Dim rng As Range
Dim sht As Worksheet
Dim pTable As PivotTable


    Set rng = ActiveSheet.Cells(1, 1).CurrentRegion
    Set sht = ActiveWorkbook.Worksheets.Add
    
    
    Set pTable = ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
        rng.Address, Version:=8).createPivotTable(TableDestination:= _
        sht.Cells(1, 1), TableName:="PivotTable" & Format(Time, "hhmmss"))
    

    With pTable
        With .PivotFields("Position Status")
            .Orientation = xlPageField
            .CurrentPage = "Active"
        End With
        With .PivotFields("Location Code")
            .Orientation = xlRowField
            .LayoutSubtotalLocation = xlAtBottom
            .LayoutForm = xlOutline
            .LayoutCompactRow = True
            .Subtotals(1) = False
        End With
        .PivotFields("Home Department Code").Orientation = xlRowField
    End With
    
End Sub

 

[chaddres]

Thank you. Is there a way to put this on a sheet named "Delivery"? The sheet number can change, so can I make this automatically named?

 

[smozgur]

You can rename the automatically added sheet's name as shown below.
Please note the first code line below already exists in the current code. Just add the second line right below the existing line.

    Set sht = ActiveWorkbook.Worksheets.Add
    sht.Name = "Delivery"

If you re-run the code then you'll get an error due to existing worksheet. Are you planning to run the code in the worksheet more than once? If so, we need to delete the existing Delivery worksheet prior creating it. Please let me know.

 

[chaddres]

This worked. It only runs once. I have one more Pivot Table to build with the below parameters.

• Rows: SSN
• Filters: DOB
• Values: Reg Hours

I did this but am not sure if it is right and do not know where to put "Reg Hours" as a value. I really appreciate your help.

With .PivotFields("DOB")
            .Orientation = xlPageField
        End With
        With .PivotFields("SSN")
            .Orientation = xlRowField
            .LayoutSubtotalLocation = xlAtBottom
            .LayoutForm = xlOutline
            .LayoutCompactRow = True
            .Subtotals(1) = False
     End With

 

[smozgur]

This worked. It only runs once. I have one more Pivot Table to build with the below parameters.

• Rows: SSN
• Filters: DOB
• Values: Reg Hours

Please post the data range (preferably as XL2BB mini-sheet since it is easy to copy data and structure for the helper) and expected Pivot Table look as you did in the original question.
Is it supposed to be a new sheet as well?

 

[chaddres]

I could not install that., but here is my code (with your code on the top half). Text in purple is what I tried to do.

Sub createPivotTableFromRange()
' Delivery Location Pivot Table
    Dim rng As Range
    Dim sht As Worksheet
    Dim pTable As PivotTable
    Set rng = ActiveSheet.Cells(1, 1).CurrentRegion
    Set sht = ActiveWorkbook.Worksheets.Add
    sht.Name = "Delivery Pivot"
    Sheets("Data").Select
    Set pTable = ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
        rng.Address, Version:=8).CreatePivotTable(TableDestination:= _
        sht.Cells(1, 1), TableName:="PivotTable" & Format(Time, "hhmmss"))
    With pTable
        With .PivotFields("Position Status")
            .Orientation = xlPageField
            .CurrentPage = "Active"
        End With
        With .PivotFields("Location Code")
            .Orientation = xlRowField
            .LayoutSubtotalLocation = xlAtBottom
            .LayoutForm = xlOutline
            .LayoutCompactRow = True
            .Subtotals(1) = False
        End With
        .PivotFields("Home Department Code").Orientation = xlRowField
    End With
    Sheets("Data").Select
'Overtime Check
    Dim rng1 As Range
    Dim sht1 As Worksheet
    Dim pTable1 As PivotTable
    Set rng1 = ActiveSheet.Cells(1, 1).CurrentRegion
    Set sht1 = ActiveWorkbook.Worksheets.Add
    sht1.Name = "Overtime Pivot"
    Sheets("Data").Select
    Set pTable1 = ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
        rng1.Address, Version:=8).CreatePivotTable(TableDestination:= _
        sht1.Cells(1, 1), TableName:="PivotTable" & Format(Time, "hhmmss"))
    With pTable1
        With .PivotFields("DOB")
            .Orientation = xlPageField
        End With
        With .PivotFields("SSN")
            .Orientation = xlRowField
            .LayoutSubtotalLocation = xlAtBottom
            .LayoutForm = xlOutline
            .LayoutCompactRow = True
            .Subtotals(1) = False
        End With
        .PivotFields("Home Department Code").Orientation = xlRowField
    End With
    Sheets("Data").Select
End Sub

 

[smozgur]

Helpers can't help you easily if you don't help them and pay attention to their questions. Personally I wouldn't like wasting time by assumptions, otherwise I would have to edit the code that I will provide with the new specs, and you will get your answer later than you hope.

1. I asked "Please post the data range". XL2BB is the preferred method, but of course you can use images as you initially did. However, in your new screenshot, I can't see the source data and I am not sure if it is in the same data table in the original question or not. Can you please clarify?
2. Is the second pivot table supposed to be a new sheet as well?
3. I understand you couldn't install the XL2BB add-in, that is perfectly fine as I indicated already. However, I don't think there is a restriction to use the code tags. The code that you pasted is barely readable. Next time, please select the code you pasted then click on the VBA button on the toolbar. It will make sure your code looks more readable (the one like I posted above. It was pretty easy to copy and paste it into your workbook, right?). No need to colorize sections, you can simply put a comment to indicate the added code, but if you still want/need to colorize code sections in the code tags, then you can use RICH button in this case, so it allows you to colorize codes in it. I am explaining this issue because I edited your previous code to wrap the code snipped with VBA BB Code and sent you an information about what and why I did. I will edit your post again.

If you could answer #1 and #2 that would be helpful to any helper who is willing to help you. (Yes, after editing your post above, I can feel the answers of my questions, but I'd like to hear from you if possible to not make assumptions).

 

[chaddres]

Thank you so much for the guidance. My spreadsheet has 40 columns but the number of rows can vary. The second pivot table should be on a sheet called "Overtime Pivot".

Sub createPivotTableFromRange()
' Delivery Location Pivot Table
    Dim rng As Range
    Dim sht As Worksheet
    Dim pTable As PivotTable
    Set rng = ActiveSheet.Cells(1, 1).CurrentRegion
    Set sht = ActiveWorkbook.Worksheets.Add
    sht.Name = "Delivery Pivot"
    Sheets("Data").Select
    Set pTable = ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
        rng.Address, Version:=8).CreatePivotTable(TableDestination:= _
        sht.Cells(1, 1), TableName:="PivotTable" & Format(Time, "hhmmss"))
    With pTable
        With .PivotFields("Position Status")
            .Orientation = xlPageField
            .CurrentPage = "Active"
        End With
        With .PivotFields("Location Code")
            .Orientation = xlRowField
            .LayoutSubtotalLocation = xlAtBottom
            .LayoutForm = xlOutline
            .LayoutCompactRow = True
            .Subtotals(1) = False
        End With
        .PivotFields("Home Department Code").Orientation = xlRowField
    End With
    Sheets("Data").Select

'This is the section I need help with
'Overtime Check
    Dim rng1 As Range
    Dim sht1 As Worksheet
    Dim pTable1 As PivotTable
    Set rng1 = ActiveSheet.Cells(1, 1).CurrentRegion
    Set sht1 = ActiveWorkbook.Worksheets.Add
    sht1.Name = "Overtime Pivot"
    Sheets("Data").Select
    Set pTable1 = ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
        rng1.Address, Version:=8).CreatePivotTable(TableDestination:= _
        sht1.Cells(1, 1), TableName:="PivotTable" & Format(Time, "hhmmss"))
    With pTable1
        With .PivotFields("DOB")
            .Orientation = xlPageField
        End With
        With .PivotFields("SSN")
            .Orientation = xlRowField
            .LayoutSubtotalLocation = xlAtBottom
            .LayoutForm = xlOutline
            .LayoutCompactRow = True
            .Subtotals(1) = False
        End With
        .PivotFields("Home Department Code").Orientation = xlRowField
    End With
    Sheets("Data").Select
End Sub

 

[smozgur]

Thanks.

You don't have to create new variables for the same objects. You can simply reuse them as shown in the code below. I commented on each step, so you can understand what's going on line by line.

Sub createPivotTableFromRange()
Dim rng As Range
Dim sht As Worksheet
Dim pCache As PivotCache
Dim pTable As PivotTable


    ' Source data range
    Set rng = ActiveSheet.Cells(1, 1).CurrentRegion
    
    ' Pivot cache object to get the data into memory to be used to create the pivot tables
    Set pCache = ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=rng.Address, Version:=8)
    
    ' Delivery Pivot Table
    ' Create a new worksheet for the delivery pivot table
    Set sht = ActiveWorkbook.Worksheets.Add
    
    ' Name the delivery worksheet
    sht.Name = "Delivery Pivot"
    
    ' Create the first pivot table for delivery
    Set pTable = pCache.createPivotTable(TableDestination:= _
        sht.Cells(1, 1), TableName:="PivotTable" & Format(Time, "hhmmss"))
    
    ' Set up pivot fields
    With pTable
        ' Filter field with the preselected option - "Active"
        With .PivotFields("Position Status")
            .Orientation = xlPageField
            .CurrentPage = "Active"
        End With
        ' Row field, layout properties to show two fields together (expanded view)
        With .PivotFields("Location Code")
            .Orientation = xlRowField
            .LayoutSubtotalLocation = xlAtBottom
            .LayoutForm = xlOutline
            .LayoutCompactRow = True
            .Subtotals(1) = False
        End With
        ' Second row field
        .PivotFields("Home Department Code").Orientation = xlRowField
    End With
    
    ' Overtime Pivot Table
    ' Create another worksheet for the overtime pivot table
    Set sht = ActiveWorkbook.Worksheets.Add
    
    ' Name the overtime worksheet
    sht.Name = "Overtime Pivot"
    
    ' Create the second pivot table for overtime by using the same pivot cache
    Set pTable = pCache.createPivotTable(TableDestination:= _
        sht.Cells(1, 1), TableName:="PivotTable" & Format(Time, "hhmmss"))
    

    ' Set up pivot fields
    With pTable
        ' Filter field
        With .PivotFields("DOB")
            .Orientation = xlPageField
        End With
        ' Row field
        With .PivotFields("SSN")
            .Orientation = xlRowField
            .Subtotals(1) = False
        End With
        ' Data field
        .PivotFields("RegHours").Orientation = xlDataField
    End With

End Sub

Please see how I used the same sht variable to create another worksheet, pTable variable to create another pivot table, and as a new addition, the same PivotCache object - pCache - as I already created it for the first pivot table.

Last thing you need to see is the last line that I added the RegHours field as an xlDataField that will generate the sum for the RegHours column.

Please let me know if you need any trouble with the code.