Как использовать цикл для категорий SUM?

Question

Я пытаюсь использовать цикл с vba для суммирования значений из одного листа в другой.Я изо всех сил пытаюсь написать свой код для сопоставления со значениями Sheet 4, и, если это значение совпадает, суммировать категории из Sheet 1, если нет, то перейти к следующему офису.Я также хотел бы исключить определенные категории из включения в цикл SUM, например, исключить «Книга».В настоящее время мой макрос пишет в Sheet3.Вот мой код:

Option Explicit

Sub test()
    Dim a, i As Long, ii As Long, dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    a = Sheets("sheet1").Cells(1).CurrentRegion.Value
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 2 To UBound(a, 1)
            If Not dic.Exists(a(i, 1)) Then dic(a(i, 2)) = dic.Count + 2
            If Not .Exists(a(i, 1)) Then
                Set .Item(a(i, 1)) = CreateObject("Scripting.Dictionary")
                .Item(a(i, 1)).CompareMode = 1
            End If
            .Item(a(i, 1))(a(i, 2)) = .Item(a(i, 1))(a(i, 2)) + a(i, 3)
        Next
        ReDim a(1 To .Count + 1, 1 To dic.Count + 1)
        a(1, 1) = Sheets("sheet1").[a1]
        For i = 0 To dic.Count - 1
            a(1, i + 2) = dic.Keys()(i)
        Next
        For i = 0 To .Count - 1
            a(i + 2, 1) = .Keys()(i)
            For ii = 2 To UBound(a, 2)
                a(i + 2, ii) = .items()(i)(a(1, ii)) + 0
            Next
        Next
    End With
    With Sheets("sheet3").Cells(1).Resize(UBound(a, 1), UBound(a, 2))
        .EntireColumn.ClearContents
        Sheets("sheet1").[a1].Copy .Rows(1)
        .Value = a: .Columns.AutoFit: .Parent.Activate
    End With
End Sub

Вот так выглядят данные

и это желаемый вывод

Answer 1

В этом примере мы будем использовать массивы для достижения того, что вы хотите.Я прокомментировал код, чтобы у вас не было проблем с его пониманием.Однако, если вы все равно это сделаете, просто спросите:)

Вход

Выход

Логика

1. Найти последнюю строку и последний столбец входного листа
2. Сохранить в массиве
3. Получить уникальные имена из столбца A и строки 1
4. Определить выходной массив
5. Сравнить массив для хранения суммы
6. Создать новоелист и вывод на этот лист

код

Option Explicit

Sub Sample()
    Dim ws As Worksheet, wsNew As Worksheet
    Dim tempArray As Variant, OutputAr() As Variant
    Dim officeCol As New Collection
    Dim productCol As New Collection
    Dim itm As Variant
    Dim lrow As Long, lcol As Long, totalsum As Long
    Dim i As Long, j As Long, k As Long

    '~~> Input sheet
    Set ws = Sheet1

    With ws
        '~~> Get Last Row and last column
        lrow = .Range("A" & .Rows.Count).End(xlUp).Row
        lcol = .Cells(1, Columns.Count).End(xlToLeft).Column

        '~~> Store it in a temp array
        tempArray = .Range(.Cells(2, 1), .Cells(lrow, lcol)).Value

        '~~> Create a unique collection using On error resume next
        On Error Resume Next
        For i = LBound(tempArray) To UBound(tempArray)
            officeCol.Add tempArray(i, 1), CStr(tempArray(i, 1))
            productCol.Add tempArray(i, 2), CStr(tempArray(i, 2))
        Next i
        On Error GoTo 0
    End With

    '~~> Define you new array which will hold the desired output
    ReDim OutputAr(1 To officeCol.Count + 1, 1 To productCol.Count + 1)

    '~~> Store the rows and columns in the array
    i = 2
    For Each itm In officeCol
        OutputAr(i, 1) = itm
        i = i + 1
    Next itm
    i = 2
    For Each itm In productCol
        OutputAr(1, i) = itm
        i = i + 1
    Next itm

    '~~> Calculate sum by comparing the arrays
    For i = 2 To officeCol.Count + 1
        For j = 2 To productCol.Count + 1
            totalsum = 0
            For k = LBound(tempArray) To UBound(tempArray)
                If OutputAr(i, 1) = tempArray(k, 1) And _
                   OutputAr(1, j) = tempArray(k, 2) Then
                   totalsum = totalsum + tempArray(k, 3)
                End If
            Next k

            OutputAr(i, j) = totalsum
        Next j
    Next i

    '~~> Create a new sheet
    Set wsNew = ThisWorkbook.Sheets.Add

    '~~> Outout the array
    wsNew.Range("A1").Resize(officeCol.Count + 1, productCol.Count + 1).Value = OutputAr
End Sub