Макрос для создания сводной таблицы

[Hugo121]

Анна, попробуйте такой вариант:

Option Explicit

Sub UniqSumm()

    Dim ilist As Worksheet, rcnt As Long
    Dim a, b, oDict As Object, i&, ii&, temp$, x&
    Dim ind&, r As Range

    For Each ilist In Worksheets
        rcnt = rcnt + ilist.UsedRange.Rows.Count
    Next

    ReDim b(1 To rcnt, 1 To 3)
    Set oDict = CreateObject("Scripting.Dictionary")
    oDict.CompareMode = 1

    For Each ilist In Worksheets
        With ilist
        Set r = Intersect(.UsedRange, .[a:c])
        If Not r Is Nothing Then
            a = r.Value
            ind = UBound(a, 2)
            For i = 1 To UBound(a)
                If Not IsEmpty(a(i, ind)) Then
                    If IsNumeric(a(i, ind)) Then
                        temp = Trim(a(i, 1)) & "|" & Trim(a(i, 2))
                        If Not oDict.Exists(temp) Then
                            ii = ii + 1
                            b(ii, 1) = Trim(a(i, 1)): b(ii, 2) = Trim(a(i, 2)): b(ii, 3) = a(i, ind)
                            oDict.Add temp, CStr(ii)
                        Else
                            x = oDict.Item(temp)
                            b(x, 3) = b(x, 3) + a(i, ind)
                        End If
                    End If
                End If
            Next
            End If
        End With
    Next

    On Error Resume Next    'если вдруг ii=0
    With Workbooks.Add.Worksheets(1)
        .Columns(1).NumberFormat = "@"
        .Range("A1:C1").Resize(ii) = b
    End With
    On Error GoTo 0

End Sub

В общем-то переменная ind в этих конкретных случаях не нужна, её можно заменить на 3, это рудимент универсального кода.
Но я решил оставить - потому, что так проще код менять под задачу - изменили например диапазон, а в коде эта переменная всегда указывает на последний элемент массива (который нужно суммировать), менять не нужно 3 на n при таких изменениях.

[АННА-ЕАО]

Hugo121 БОЛЬШОЕ, БОЛЬШОЕ ВАМ СПАСИБО. Данный код работает в моем файле (с моими данными).
А можно ещё вопросик?
Тот макрас который похож на Результирующий_файл.xls: и в котором я все заменила, что Вы мне сказали у меня работал , но только в файле который был для примера дан изначально, а в моеём файле работать отказывается выделяет мне жёлтым цветом данную строчку:
b(ii, 1) = temp: b(ii, 2) = Trim(a(i, 2)): b(ii, 3) = Trim(a(i, 4)): b(ii, ubb) = a(i, 3). Что не так?

[Hugo121]

Я думаю, что проблема в a(i, 4) - если у Вас диапазон не

[a:d]

, а уже, то такого элемента нет.
Эта строка вероятно так должна быть написана:

b(ii, 1) = Trim(a(i, 1)): b(ii, 2) = Trim(a(i, 2)): b(ii, ubb) = a(i, 3)

[АННА-ЕАО]

Hugo121 Да, так код работает, но...
Видимо данный код как то рассчитан толи на количество листов в книге (из который мы хотим взять данные), то ли на то что заполняются только 21 графа. Т.е. если в моем файле только 15 листов с данными, то в результате я получаю таблицу, которая меня устраивает, но после 17 графы по 21 все заполняется такими знаками #Н/Д, это конечно не беда я и удалить их могу, но...
В моем файле 75 листов и в итоге в сводной таблице по данному макросу получается, что заполняется только 21 графа (1-номер, 2- наименование, с 3 по 21 суммы) т.е. данные взялись только с первых 19 листов.
Как можно решить такую проблему?

[Hugo121]

Проблему всегда можно решить...
Чуть прокомментирую.

'определяем массив высотой с сумму количества строк ранее просмотренных листов
ReDim b(1 To rcnt, 1 To 3)

'определяем, использованы ли вообще выбранные столбцы, определяем нужный диапазон
Set r = Intersect(.UsedRange, .[a:c])
'если использовались
If Not r Is Nothing Then
'данные в массив
a = r.Value
ind = UBound(a, 2)
For i = 1 To UBound(a)
'если есть что суммировать
If Not IsEmpty(a(i, ind)) Then
'если это цифра, а не буквы
If IsNumeric(a(i, ind)) Then

...
...
'выгружаем с первой строки по число использованных строк массива
.Range("A1:C1").Resize(ii) = b


Если у Вас #Н/Д, то это значит, что переменная ii имеет не то значение (больше нужного), или массив меньше, чем Вы задали выгрузку.
В общем, желательно видеть пример файла.

[АННА-ЕАО]

Вот файлы для примера .

[Hugo121]

Да, была моя ошибка - выгрузка была нединамическая
Вот тут: .Range("A1:C1").Resize или .Range("A1:U1").Resize...

Option Explicit


Sub UniqSumm()
    Dim ilist As Worksheet, rcnt As Long, scnt As Long, ubb As Long, ash As Long
    Dim a, b, oDict As Object, i&, ii&, temp$, x&
    Dim r As Range

    For Each ilist In Worksheets
        With ilist
            Set r = Intersect(.UsedRange, .[a:c])
        End With
        If Not r Is Nothing Then
        scnt = scnt + 1
        rcnt = rcnt + ilist.UsedRange.Rows.Count
        End If
    Next

    ubb = scnt + 3
    ReDim b(1 To rcnt + 1, 1 To ubb)
    b(1, 1) = "PART N"
    b(1, 2) = "Description"
    b(1, ubb) = "ВСЕГО"
    
    Set oDict = CreateObject("Scripting.Dictionary")
    oDict.CompareMode = 1
    ii = 1: ash = 2
    For Each ilist In Worksheets
        With ilist
        Set r = Intersect(.UsedRange, .[a:c])
        If Not r Is Nothing Then
            a = r.Value
            ash = ash + 1
            b(1, ash) = .Name
            For i = 1 To UBound(a)
                If Not IsEmpty(a(i, 3)) Then
                    If IsNumeric(a(i, 3)) Then
                        temp = Trim(a(i, 1)) & "|" & Trim(a(i, 2))
                        If Not oDict.Exists(temp) Then
                            ii = ii + 1
                            b(ii, ash) = a(i, 3)
                            b(ii, 1) = Trim(a(i, 1)): b(ii, 2) = Trim(a(i, 2)): b(ii, ubb) = a(i, 3)
                            oDict.Add temp, CStr(ii)
                        Else
                            x = oDict.Item(temp)
                            b(x, ash) = a(i, 3)
                            b(x, ubb) = b(x, ubb) + a(i, 3)
                        End If
                    End If
                End If
            Next
            End If
        End With
    Next

    On Error Resume Next    'если вдруг ii=0
    With Workbooks.Add.Worksheets(1)
        .Columns(1).NumberFormat = "@"
        .Range(.[A1], .Cells(1, ubb)).Resize(ii) = b
        .UsedRange.EntireColumn.AutoFit
    End With
    On Error GoTo 0
End Sub

[Hugo121]

Код выше слегка изменил - так правильнее.

[АННА-ЕАО]

Hugo121 ОГРОМНОЕ, ОГРОМНОЕ ВАМ СПАСИБО Все получилось.
Буду работать, пользоваться и вспоминать Вас добрым словом. Спасибо.

[Hugo121]

На здоровье

Кстати, если "Буду работать, пользоваться", то удобнее этот код держать в отдельном файле.

1. Открыть этот файл
2. Открыть анализируемый файл.
3. По Alt+F8 выбрать макрос UniqSumm из ЭТОГО файла.