Question

我正在尝试使用带有vba的循环将一个工作表中的值汇总到另一个工作表中。我正在努力编写代码以匹配Sheet 4中的值，如果该值匹配，则对Sheet 1中的类别求和，如果不匹配，则跳到下一个办公室。我还想从SUM循环中排除某些类别，例如，排除“ Book”。目前，我的宏正在写入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

在此示例中，我们将使用数组来实现所需的功能。我对代码进行了注释，以使您在理解它时不会遇到问题。但是，如果您仍然这样做，则只需问：）

输入

输出

逻辑

查找输入表的最后一行和最后一列
存储在数组中
从A列和第1行获取唯一名称
定义输出数组
比较数组以存储总和
创建新工作表并输出到该工作表

代码

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

如何使用循环到SUM类别？

1 个答案: