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

[igsxor]

Доброго времени.
Подскажите,есть ли готовое или примерное решения для задачи:
Необходимо выбрать из каждого листа книги повторяющиеся номера(столбец А),суммировать число(количество шт.) из этой строки с количеством шт.из другого листа,если есть идентичный номер с повторяющимся номером(столбец А) таким же номером из другого листа.

Результирующая сводная таблица нужна без найденных дублей номеров.

[Hugo121]

Переделал быстренько код из темы http://www.planetaexcel.ru/forum.php?thread_id=26105
Это если нужны только номера и сумма количества.

Sub UniqSumm()    'вариант без Transpose - для больших объёмов

    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 2)
    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))
                        If Not oDict.Exists(temp) Then
                            ii = ii + 1
                            b(ii, 1) = temp: b(ii, 2) = a(i, ind)
                            oDict.Add temp, CStr(ii)
                        Else
                            x = oDict.Item(temp)
                            b(x, 2) = b(x, 2) + 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:B1").Resize(ii) = b
    End With
    On Error GoTo 0

End Sub

Код поместить в модуль любого файла и выполнить на активной книге Rebuild.
Результат будет в новой книге.
P.S. Результат почти сошёлся...

[Watcher_1]

На листе Лист1 есть кнопка нажмите на нее и посмотрите на результат

Думаю смысл вашей задачи уловлен, но этот макрос надо будет заточить под ваши нужды

[Hugo121]

Наши результаты совпадают, только у меня названия не тянутся. Хотя это несложно добавить.

P.S. Добавил.

[Hugo121]

Ну а этот код сделает таблицу, похожую на Результирующий_файл.xls:

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 + 4
    ReDim b(1 To rcnt + 1, 1 To ubb)
    b(1, 1) = "PART N"
    b(1, 2) = "Description"
    b(1, 3) = "UOM"
    b(1, ubb) = "всего деталей"
    
    Set oDict = CreateObject("Scripting.Dictionary")
    oDict.CompareMode = 1
    ii = 1
    For Each ilist In Worksheets
        With ilist
        Set r = Intersect(.UsedRange, .[a:d])
        If Not r Is Nothing Then
            a = r.Value
            ash = ash + 1
            b(1, ash + 3) = .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))
                        If Not oDict.Exists(temp) Then
                            ii = ii + 1
                            b(ii, ash + 3) = a(i, 3)
                            b(ii, 1) = temp: b(ii, 2) = Trim(a(i, 2)): b(ii, 3) = Trim(a(i, 4)): b(ii, ubb) = a(i, 3)
                            oDict.Add temp, CStr(ii)
                        Else
                            x = oDict.Item(temp)
                            b(x, ash + 3) = 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]

Возможно.
Замените
temp = Trim(a(i, 1))
на
temp = Trim(a(i, 1)) & "|" & Trim(a(i, 2))
Так отбор уникальных будет происходить по связке двух столбцов.
Ну там конечно вывод результатов ещё нужно скорректировать, но это нужно по месту смотреть.

[АННА-ЕАО]

Почти получилось, только можно чтоб в итоге данные из граф А и В не сливались, а были по отдельным графам. Т.е. Вид таблицы в результате должен быть так же из 3-х граф (1-номер, 2-наименование, 3-сумма).

[Hugo121]

Чтоб не сливались - в коде есть строка
b(ii, 1) = temp: b(ii, 2) = Trim(a(i, 2)): ...
замените на
b(ii, 1) = Trim(a(i, 1)): b(ii, 2) = Trim(a(i, 2)): ...

Т.е. смысл в том, что в словаре мы держим слитое из двух ячеек значение, и сверяемся с слитым значением, а в массив результатов заносим другие данные этой строки, какие нам нужно. Можно слитые, можно исходные раздельно, как угодно - главное заранее заготовить массив в ширину по размеру, и прописать, что куда помещаем.

[АННА-ЕАО]

Hugo121 Большое спасибо. Заменила в макросе который похож на Результирующий_файл.xls: все получилось. Но Вы первый макрас предлагали вчера мне он больше подходит, что и на что в нем нужно заменить чтоб в итоге данные из граф А и В не сливались?