Option Explicit

Public Sub Макрос3()
Dim w As Workbook, sh As Worksheet, nLastRow As Long, shPivot As Worksheet

' Получаем книгу с которой будем работать
Set w = ActiveWorkbook

    Application.ScreenUpdating = False
'Фильтр на несоответствие
    With w.Sheets("Лист1").Range("A1").CurrentRegion
        .AutoFilter Field:=1, Criteria1:="=41**", Operator:=xlAnd
        .AutoFilter Field:=2, Criteria1:="<>"
'Вставляем в лист2
        .Copy w.Sheets("Лист2").Range("A1")
    End With

'Подтягиваем значения из справочника
    With w.Sheets("Лист2")
        nLastRow = .Cells.End(xlDown).Row
        .Columns("E").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
        .Range("E1:E" & CStr(nLastRow)).FormulaR1C1 = "=VLOOKUP(RC[-1],Справочник!R1C1:R22C2,2)"
    End With

'Вставляем шапку (Переименуем колонки)
    With Sheets("Лист2")
        .Range("A1").Value = "Конт. счет"
        .Range("B1").Value = "Потребитель"
        .Range("C1").Value = "№ дата, дог."
        .Range("D1").Value = "№ уст-ки"
        .Range("E1").Value = "Вид установки"
        .Range("F1").Value = "ФАКТ"
        .Range("G1").Value = "ПЛАН"
'    Sheets("Лист2").Range("H1").Value = "отк. кВтч"
'    Sheets("Лист2").Range("I1").Value = "отк. %"
    End With

'вАяем сводную таблицу
    Set shPivot = CheckSheet(w, "Сводная")
    Call CrPvTab(w, shPivot)
'Фильтруем Сводную таблицу по категориям и формируем вкладки
' Прочие
'
    Call ClearFl(shPivot, "Прочие*")
    Call CrSheet(w, shPivot, "Прочие")
' Бюджет
'
    Call ClearFl(shPivot, "Бюджетные*")
    Call CrSheet(w, shPivot, "Бюджет")
' Сельхоз
'
    Call ClearFl(shPivot, "Сельскохоз*")
    Call CrSheet(w, shPivot, "Сельхоз")
' Население
'
    Call ClearFl(shPivot, "*насел*")
    Call CrSheet(w, shPivot, "Население")
' Компенсация
'
    Call ClearFl(shPivot, "Компенсация*")
    Call CrSheet(w, shPivot, "Компенсация")

Application.ScreenUpdating = True

End Sub

Public Sub CrPvTab(w As Workbook, sh As Worksheet)
'
' формируем сводную таблицу
'
    w.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
        "Лист2!R1C1:R65536C7", Version:=xlPivotTableVersion10).CreatePivotTable _
        TableDestination:=sh.Name & "!R3C1", TableName:=sh.Name, _
        DefaultVersion:=xlPivotTableVersion10
    With sh.PivotTables(sh.Name)
        With .PivotFields("Вид установки")
            .Orientation = xlPageField
            .Position = 1
        End With
        With .PivotFields("Потребитель")
            .Orientation = xlRowField
            .Position = 1
        End With
        With .PivotFields("№ дата, дог.")
            .Orientation = xlRowField
            .Position = 2
        End With

        With .PivotFields("Потребитель")
            .Subtotals = Array(False, False, False, False, False, False, False, False, False, False, _
                False, False)
        End With
        With .PivotFields("№ дата, дог.")
            .Subtotals = Array(False, False, False, False, False, False, False, False, False, False, _
                False, False)
        End With

        .AddDataField .PivotFields("ФАКТ"), "Количество по полю ФАКТ", xlCount
        .AddDataField .PivotFields("ПЛАН"), "Количество по полю ПЛАН", xlCount

        With .DataPivotField
            .Orientation = xlColumnField
            .Position = 1
        End With
        With .PivotFields( _
            "Количество по полю ФАКТ")
            .Caption = "Сумма по полю ФАКТ"
            .Function = xlSum
        End With

        With .PivotFields( _
            "Количество по полю ПЛАН")
            .Caption = "Сумма по полю ПЛАН"
            .Function = xlSum
        End With
    End With

End Sub

Sub ClearFl(sh As Worksheet, sFilters As String)
Dim pi As PivotItem
' Скрываем и показываем нужные поля сводной
    With sh.PivotTables(sh.Name).PivotFields("Вид установки")
        For Each pi In .PivotItems
            If pi.Name Like sFilters Then
                pi.Visible = True
            Else
                pi.Visible = False
            End If
        Next pi
    End With
End Sub

Sub CrSheet(w As Workbook, sh As Worksheet, sNameSheet As String)
'Копируем сводную таблицу
Dim shDest As Worksheet

    Set shDest = CheckSheet(w, sNameSheet)
    LsClRg(sh, 4).Copy
    shDest.Cells.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
'Вставляем формЫлы
    Call FmlAdd(shDest)
'Вставляем шапку
    Call RenTab(shDest)
End Sub

Sub FmlAdd(sh As Worksheet)
' Здесь как-то не понятно, в один и тот-же диапазон вставляем разные значения. Правильно ли это???
'Вставляем формулы кВтч
Dim r As Range
    Set r = LsClRg(sh)
    With r
        .FormulaR1C1 = "=RC[-2]-RC[-1]"
        .NumberFormat = "General"
'Вставляем формулы %
        .FormulaR1C1 = "=IF(RC[-3]=0,0,RC[-3]/RC[-2])-1"
        .NumberFormat = "0.00%"
    End With
End Sub

Function LsClRg(sh As Worksheet, Optional nStartRowCopy As Long = 2) As Range
'Адрес последнего столбца +1
Dim r As Range
    Set r = sh.Cells.SpecialCells(xlLastCell)
    Set LsClRg = sh.Range(sh.Cells(nStartRowCopy, r.Column + 1), sh.Cells(r.Row, r.Column + 1))
End Function

Sub RenTab(sh As Worksheet)
'Вставляем шапку (Переименуем колонки)
    With sh
        .Range("A1").Value = "Потребитель"
        .Range("B1").Value = "№ дата, дог."
        .Range("C1").Value = "№ уст-ки"
        .Range("D1").Value = "Вид установки"
        .Range("E1").Value = "ФАКТ"
        .Range("F1").Value = "ПЛАН"
        .Range("G1").Value = "отк. кВтч"
        .Range("H1").Value = "отк. %"
    End With
End Sub

Private Function CheckSheet(w As Workbook, sName As String) As Worksheet
    On Error GoTo labErr
    ' Пробуем получить лист, если он есть, получаем и возвращаем, если листа нет
    ' получаем ошибку и по ней добавляем лист
    Set CheckSheet = w.Sheets(sName)
    Exit Function
labErr:
    Set CheckSheet = w.Sheets.Add
    CheckSheet.Name = sName
End Function