Сводная с одинаковых листов со сложной (неподготовленной) структурой данных

Option Explicit
 
Private wb_Data_Pivot As Workbook, ws_data As Worksheet
 
Public Sub Сводная_Листы()
 
    Application.ScreenUpdating = False
    Dim arr_ws    'Листы
    arr_ws = ThisWorkbook.Worksheets("Обзор").Columns(3).SpecialCells(xlCellTypeConstants)
    ' Собрать бренды
    Dim wb_brand As Workbook, ws_brand As Worksheet, ws As Worksheet
    Set wb_brand = Workbooks.Add
    Set ws_brand = ActiveSheet
    Dim x As Long
 
    'Собрать нужные листы на один лист
    For Each ws In ThisWorkbook.Worksheets
        For x = LBound(arr_ws) To UBound(arr_ws)
            If CStr(ws.Name) = CStr(arr_ws(x, 1)) Then
 
                ws.UsedRange.Copy ws_brand.Cells(ws_brand.UsedRange.Rows.Count + 1, 1)
            End If
        Next
    Next
 
    'Подготовка данных для сводной
    Строки_Пустые_Удалить ws_brand
 
    Строки_Содержащие_Текст_в_Столбце_Удалить _
            ws_brand, 1, vbNullString, 3
    Строки_Содержащие_Текст_в_Столбце_Удалить _
            ws_brand, 3, "Кол-во", 3
 
    UnMerge_and_Fill_by_Value ws_brand.Rows(1)
 
    Столбец_Содержащий_Текст_Удалить ws_brand, "Кол-во"
 
    Столбец_Содержащий_Текст_Удалить ws_brand, "Остатки"
 
    Redesigner_Pavlov ws_brand.Cells(2, 1)
 
    ' Сделать сводную
    Данные_Тюнинг
 
    Сводная_Создать
 
    wb_brand.Close False
    wb_Data_Pivot.Close False
 
    ThisWorkbook.Worksheets("Summa").Activate
 
    Application.ScreenUpdating = True
End Sub
 
Private Sub Данные_Тюнинг()
    With ws_data
        .Rows(1).Insert
        .[a1].Resize(1, 6) = Array("Товар", "Цена", "Дата", "Тип", "Штук", "Сумма")
        .Range("F2").FormulaR1C1 = "=RC[-4]*RC[-1]"
 
        Dim rng As Range
        Set rng = .Range(.Cells(2, 6), _
                         .Cells(.UsedRange.Rows.Count, 6))
 
        rng.FillDown
 
        .Calculate
    End With
End Sub
 
Sub Redesigner_Pavlov(rng As Range)
    'Private wb_Data_Pivot As Workbook в начало модуля
    Dim i As Long
    Dim hc As Long, hr As Long, r As Long, c As Long, j As Long, k As Long
    Dim inpdata As Range
 
    'hr = InputBox("Сколько строк с подписями сверху?")
    hr = 2
    'hc = InputBox("Сколько столбцов с подписями слева?")
    hc = 2
    Application.ScreenUpdating = False
 
    i = 1
    'Set inpdata = Selection
    Set inpdata = rng.CurrentRegion
    Set wb_Data_Pivot = Workbooks.Add
    Set ws_data = ActiveSheet
 
    With inpdata
        For r = (hr + 1) To .Rows.Count
            For c = (hc + 1) To .Columns.Count
                For j = 1 To hc
                    ws_data.Cells(i, j) = .Cells(r, j)
                Next j
 
                For k = 1 To hr
                    ws_data.Cells(i, j + k - 1) = .Cells(k, c)
                Next k
 
                ws_data.Cells(i, j + k - 1) = .Cells(r, c)
                i = i + 1
            Next c
        Next r
    End With
End Sub
 
 
Public Sub Строки_Пустые_Удалить(Optional sh As Worksheet)
    Dim r As Long, rng As Range
 
    For r = 1 To sh.UsedRange.Row - 1 + sh.UsedRange.Rows.Count
        If Application.WorksheetFunction.CountA(sh.Rows(r)) = 0 Then
            If rng Is Nothing Then
                Set rng = sh.Rows(r)
            Else
                Set rng = Union(rng, sh.Rows(r))
            End If
        End If
    Next r
    If Not rng Is Nothing Then rng.EntireRow.Delete
End Sub
 
Public Sub Дубликаты_Удалить(rg As Range)
    'не работает в общем доступе. Удалить дубликаты в любом диапазоне
    If Not ActiveWorkbook.MultiUserEditing Then
        Set rg = rg.CurrentRegion
        Dim lCol As Long, lr As Long, li As Long
        Dim arr()
        lr = rg.Row + rg.Rows.Count - 1
        lCol = rg.Column + rg.Columns.Count - 1
 
        ReDim arr(0 To lCol - 1)
        For li = 1 To lCol
            arr(li - 1) = li
        Next li
 
        rg.Cells.MergeCells = False
        rg.RemoveDuplicates arr, xlYes
    Else
        ' MsgBox "не работает в общем доступе", vbCritical, "RemoveDuplicates"
    End If
End Sub
 
Public Sub Строки_Содержащие_Текст_в_Столбце_Удалить(ByRef sh As Worksheet, _
                                                     Столбец As Long, Строка As String, Optional iRow As Long)
    Dim r As Long, rng As Range
    Application.StatusBar = "Ищу " & Строка
 
    With sh
 
        For r = iRow To .UsedRange.Row - 1 + .UsedRange.Rows.Count
            If Строка <> vbNullString Then    ' если НЕпусто
 
                If InStr(.Cells(r, Столбец).Value, Строка) > 0 Then
 
                    If rng Is Nothing Then
                        Set rng = .Rows(r)
                    Else
                        DoEvents
                        Set rng = Union(rng, .Rows(r))
                    End If
                End If
 
            Else    'если Пусто
 
                If IsEmpty(.Cells(r, Столбец).Value) Then
 
                    If rng Is Nothing Then
                        Set rng = .Rows(r)
                    Else
                        DoEvents
                        Set rng = Union(rng, .Rows(r))
                    End If
                End If
 
            End If
 
        Next r
    End With
    Application.StatusBar = "Удаляю " & Строка
 
    If Not rng Is Nothing Then rng.EntireRow.Delete
 
    Application.StatusBar = vbNullString
 
End Sub
 
Sub UnMerge_and_Fill_by_Value(rRange As Range)
    '---------------------------------------------------------------------------------------
    ' Procedure : UnMerge_and_Fill_by_Value
    ' Author    : The_Prist ( http://www.planetaexcel.ru/forum.php?thread_id=3760&thread_id=3760&page_forum=lastpage&allnum_forum=14#post86381 )
    ' Date      : 23.12.2009
    ' Purpose   : Снимает объединение со всех ячеек выделенного диапазона _
      и заполняет все разгруппированные ячейки каждой бывшей группы значениями верхней левой
    '---------------------------------------------------------------------------------------
    Dim sValue As String, sAddress As String
    Dim rCell As Range
    Dim lLastRow As Long, lLastCol As Long
    Dim ws As Worksheet
    Set ws = rRange.Parent
    lLastRow = ws.Cells.SpecialCells(xlLastCell).Row
    lLastCol = rRange.Column + rRange.Columns.Count - 1
    Application.ScreenUpdating = False
 
 
    With rRange
        Set rRange = Intersect(rRange, _
                               Range(ws.Cells(.Row, .Column), ws.Cells(lLastRow, lLastCol)))
    End With
 
    For Each rCell In rRange
        With rCell
            If .MergeCells Then
                sValue = .Value
                sAddress = _
                .MergeArea.Address
                .UnMerge
                Range(sAddress).Value = _
                .Value
            End If
        End With
    Next
 
End Sub
 
Private Sub Столбец_Содержащий_Текст_Удалить(ws As Worksheet, _
                                           str As String)
    Dim x As Long, rng As Range, r As Range
 
    With ws
        For x = 1 To .UsedRange.Columns.Count
 
            Set r = .Columns(x).Find(what:=str, LookIn:=xlValues, lookAt:=xlWhole)
            If Not r Is Nothing Then
                If rng Is Nothing Then
                    Set rng = .Columns(x)
                Else
                    DoEvents
                    Set rng = Union(rng, .Columns(x))
                End If
            End If
        Next
 
    End With
 
    If Not rng Is Nothing Then rng.EntireColumn.Delete
End Sub
 
Private Sub Сводная_Создать()
    ThisWorkbook.Worksheets("Summa").Cells.Clear
    ' Workbooks("InExSu sum_if.xlsb").PivotCaches.Create(SourceType:=xlDatabase, _
      SourceData:="[Книга12]Лист1!R1C1:R58C6", Version:=xlPivotTableVersion14). _
      CreatePivotTable TableDestination:="[InExSu sum_if.xlsb]Summa!R1C1", _
      TableName:="СводнаяТаблица2", DefaultVersion:=xlPivotTableVersion14
 
    ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, _
                                    SourceData:=ws_data.UsedRange, Version:=xlPivotTableVersion14). _
                                    CreatePivotTable TableDestination:=ThisWorkbook.Worksheets("Summa").[a1], _
                                    TableName:="СводнаяТаблица2", DefaultVersion:=xlPivotTableVersion14
 
    '    Windows("InExSu sum_if.xlsb").Activate
    With ThisWorkbook.Worksheets("Summa").PivotTables("СводнаяТаблица2")
        With .PivotFields("Товар")
            .Orientation = xlRowField
            .Position = 1
        End With
        With .PivotFields("Дата")
            .Orientation = xlColumnField
            .Position = 1
        End With
        .AddDataField .PivotFields("Сумма"), "Сумма по полю Сумма", xlSum
        With .PivotFields( _
             "Сумма по полю Сумма")
            .NumberFormat = "# ##0"
        End With
        ThisWorkbook.Worksheets("Summa").Columns("B:B").ColumnWidth = 7.78
    End With
 
End Sub