Sub Сводная_с_нескольких_листов()

    Dim shRes As Worksheet, shSvod As Worksheet, sh As Worksheet, PivTable As PivotTable
    Dim lr As Long, i As Long
    
    Application.ScreenUpdating = False
    
    Set shRes = Worksheets.Add(After:=Worksheets(Worksheets.Count))
    For i = 1 To Worksheets.Count - 1
        Set sh = Worksheets(i)
        If i = 1 Then
            sh.usedrange.Copy
            shRes.Range("A1").PasteSpecial xlPasteAll
            shRes.Range("A1").PasteSpecial xlPasteColumnWidths
        Else
            lr = shRes.usedrange.Rows.Count + 1
            sh.usedrange.Offset(1).Copy
            shRes.Cells(lr, "A").PasteSpecial xlPasteAll
            shRes.Cells(lr, "A").PasteSpecial xlPasteColumnWidths
        End If
    Next i
    shRes.Columns.WrapText = False
    
    Корректировка_PRICE shRes
    If Удаление_строк_у_которых_Оплачено_не_равно_нулю(shRes) = False Then
        Exit Sub
    End If
    
    Set shSvod = Worksheets.Add(After:=shRes)
    ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, _
        SourceData:=shRes.usedrange.Address(ReferenceStyle:=xlR1C1, External:=True), _
        Version:=6).CreatePivotTable _
        TableDestination:=shSvod.Range("A3").Address(ReferenceStyle:=xlR1C1, External:=True), _
        DefaultVersion:=6
    Set PivTable = shSvod.PivotTables(1)
    With PivTable.PivotFields("customers.NAME")
        .Orientation = xlRowField
        .Position = 1
    End With
    PivTable.AddDataField PivTable.PivotFields("PRICE"), "Сумма по полю PRICE", xlSum
    
    Application.ScreenUpdating = True

End Sub

Private Sub Корректировка_PRICE(shRes As Worksheet)

    Dim arrE(), arrF()
    Dim var, lr As Long, boolHasStaff As Boolean, i As Long, ii As Long
    
    lr = shRes.Cells(shRes.Rows.Count, "A").End(xlUp).Row
    arrE() = shRes.Range("E2:E" & lr).Value
    arrF() = shRes.Range("F2:F" & lr).Value
    For i = 1 To UBound(arrE)
        boolHasStaff = False
        If InStr(arrE(i, 1), "Staff") <> 0 Then
            var = Split(arrE(i, 1), " ")
            For ii = 0 To UBound(var)
                If var(ii) = "Staff" Then
                    boolHasStaff = True
                    Exit For
                End If
            Next ii
            If boolHasStaff = False Then
                arrF(i, 1) = arrF(i, 1) / 2
            End If
        Else
            arrF(i, 1) = arrF(i, 1) / 2
        End If
    Next i
    shRes.Range("F2:F" & UBound(arrF)).Value = arrF()
    
End Sub

Private Function Удаление_строк_у_которых_Оплачено_не_равно_нулю(shRes As Worksheet) As Boolean

    Dim arr(), lr As Long, lr2 As Long
    
    lr = shRes.Cells(shRes.Rows.Count, "A").End(xlUp).Row
    arr() = shRes.Range("I2:I" & lr).Value
    For i = 1 To UBound(arr)
        If arr(i, 1) <> 0 Then
            arr(i, 1) = Empty
        End If
    Next i
    shRes.Range("I2:I" & lr).Value = arr()
    shRes.Sort.Header = xlYes
    shRes.Sort.SortFields.Add key:=shRes.Columns("I")
    shRes.Sort.SetRange shRes.Columns("A:I")
    shRes.Sort.Apply
    lr = shRes.Cells(shRes.Rows.Count, "I").End(xlUp).Row
    If lr < 2 Then
        MsgBox "На всех листах в столбце ""Оплачено"" не нули!", vbInformation
        Exit Function
    End If
    lr2 = shRes.Cells(shRes.Rows.Count, "A").End(xlUp).Row
    If lr < lr2 Then
        shRes.Rows(lr + 1 & ":" & lr2).Delete
    End If
    Удаление_строк_у_которых_Оплачено_не_равно_нулю = True
    
End Function