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