Copy pivottables subtotal to new sheet.

[Admin]

Hi

Try this.

Sub kTest()
    
    Dim dicEnviro   As Object, i As Long, j As Long, k, q, t
    Dim wksAllTotals    As Worksheet, wksTotals As Worksheet
    
    Set dicEnviro = CreateObject("scripting.dictionary")
        dicEnviro.comparemode = 1
        
    Set wksAllTotals = ThisWorkbook.Worksheets("All Total Calc")
    Set wksTotals = ThisWorkbook.Worksheets("Totals")
    
    q = wksAllTotals.Range("b2").CurrentRegion.Resize(, 2).Value2
    
    For i = 1 To UBound(q, 1)
        If LenB(q(i, 1)) Then
            dicEnviro.Item(q(i, 1)) = Array(i, 0)
        End If
    Next
    
    For j = 1 To wksTotals.PivotTables.Count
        k = wksTotals.PivotTables(j).TableRange1.Value2
        For i = 1 To UBound(k, 1)
            t = dicEnviro.Item(k(i, 1))
            If Not IsEmpty(t) Then
                t(1) = t(1) + k(i, 2)
                q(t(0), 2) = t(1)
                dicEnviro.Item(k(i, 1)) = t
            End If
        Next
    Next
    
    wksAllTotals.Range("b2").CurrentRegion.Resize(, 2) = q
    
End Sub

[jwitte]

Hi

Try this.

Sub kTest()
    
    Dim dicEnviro   As Object, i As Long, j As Long, k, q, t
    Dim wksAllTotals    As Worksheet, wksTotals As Worksheet
    
    Set dicEnviro = CreateObject("scripting.dictionary")
        dicEnviro.comparemode = 1
        
    Set wksAllTotals = ThisWorkbook.Worksheets("All Total Calc")
    Set wksTotals = ThisWorkbook.Worksheets("Totals")
    
    q = wksAllTotals.Range("b2").CurrentRegion.Resize(, 2).Value2
    
    For i = 1 To UBound(q, 1)
        If LenB(q(i, 1)) Then
            dicEnviro.Item(q(i, 1)) = Array(i, 0)
        End If
    Next
    
    For j = 1 To wksTotals.PivotTables.Count
        k = wksTotals.PivotTables(j).TableRange1.Value2
        For i = 1 To UBound(k, 1)
            t = dicEnviro.Item(k(i, 1))
            If Not IsEmpty(t) Then
                t(1) = t(1) + k(i, 2)
                q(t(0), 2) = t(1)
                dicEnviro.Item(k(i, 1)) = t
            End If
        Next
    Next
    
    wksAllTotals.Range("b2").CurrentRegion.Resize(, 2) = q
    
End Sub

Hi

It could be that its to early in the morning or the fact im a total VBA newbie or the fact i didnt explain properly what i wanted here but it doesnt paste the the totals to the all totals page. It could also be that i didnt explain myself. i need it to look for the BSP in the 4 pivot tables and give me a total count of the sub total. If table "CW" has a cound of 100 for bsp and table "LF" has a count of 5 and table "MS" has a count of 10 and table "US" has a count of 15 for bsp, on the all totals page it would put BSP = 130(total for bsp in all pivot tables). I would need that for each row, and if one table does have that row it would count it as 0. And give me the total of the other pivot tables that may have a value. I need a total count for each of the following.

"BSP"
"BWF"
"CAN"
"CTC"
"DSP"
"LNP"
"MSP"
"PSP"
"TC"
"TSP"
"USP"
"VSH"
"VSP"

I am totally sorry if I sound confusing or not making sence. I want something like below but count "BSP" in all 4 tables and insert that total on the all totals sheet, and just count a 0 if one of the above stages dont exist in one of the tables. I can copy that code and change it for each stage above but it errors out if a table doesnt have that stage. I cant get it to work poperly in the loop.

ActiveSheet.PivotTables("CW").PivotSelect "BSP", xlDataAndLabel + xlFirstRow, True
Selection.Copy
Range("N4").Select
ActiveSheet.Paste