Question

这是my previous post的补充问题。我无法找到解决数小时的方法，也无法通过在线搜索找到想法。

假设我在Excel表格中有以下数据（实际数据可能是数千或数百万）（表1）：

Name    Entry   No. ID  Expense 1   Expense 2
A       1       A1      14          5
B       2       B4      12          7
B       2       B5      20          8
C       3       C0      19          7
D       4       -       0           0
A       1       A1      11          6
A       1       A2      20          5
E       5       -       0           0
F       6       -       0           0
C       3       C0      15          5
B       2       B5      20          4
B       2       B5      16          3
B       2       B5      12          7
B       2       B6      18          8
A       1       A1      10          1
A       1       A1      14          7
A       1       A2      10          2
B       2       B3      13          7
B       2       B3      14          1
B       2       B3      11          4

上面列号ID中的字符（ - ）也可以是数字0或空白单元格。

我想格式化上述数据如下（表2）

Name    Entry   No. ID  Number of ID    Sum of Expense 1    Sum of Expense 2
A       1       A1      2               49                  19
A       1       A2      2               30                  7
B       2       B3      4               38                  12
B       2       B4      4               12                  7
B       2       B5      4               68                  22
B       2       B6      4               18                  8
C       3       C0      1               34                  12
D       4       -       0               0                   0
E       5       -       0               0                   0
F       6       -       0               0                   0

列号ID表示A有2个ID（A1和A2），B有4个ID（B1，B2，B3和B4），C有1个ID（C0），D，E和F没有ID。费用1和2的总和是每个费用的所有费用的总和。 ID。

使用数据透视表可以获得的最佳效果就像这样

如何在MS Excel中执行表2之类的任务？如果可能的话，可以使用VBA脚本。

Answer 1

下面的代码可能有所帮助：

<强>假设：

1。您的数据位于ActiveSheet中 2。结果将显示在Sheet2

中

Sub Demo()
    Dim dict1 As Object, dict2 As Object
    Dim c1 As Variant, c2 As Variant
    Dim i As Long, lastRow As Long, targetRow As Long, count As Long
    Dim targetWS As Worksheet

    Set targetWS = ThisWorkbook.Sheets("Sheet2")
    Set dict1 = CreateObject("Scripting.Dictionary")
    Set dict2 = CreateObject("Scripting.Dictionary")

    'get last row with data
    lastRow = Cells(Rows.count, "A").End(xlUp).Row

    'assign unique values in Column A (Name) to dict1
    c1 = Range("A2:A" & lastRow)
    For i = 1 To UBound(c1, 1)
        dict1(c1(i, 1)) = 1
    Next i

    'assign unique values in Column C (No. Id) to dict2        
    c2 = Range("C2:C" & lastRow)
    For i = 1 To UBound(c2, 1)
        dict2(c2(i, 1)) = 1
    Next i

    'write headers in Sheet2
    targetWS.Cells(1, 1) = "Name"
    targetWS.Cells(1, 2) = "Entry"
    targetWS.Cells(1, 3) = "No. Id"
    targetWS.Cells(1, 4) = "Number of ID"
    targetWS.Cells(1, 5) = "Sum of Expense 1"
    targetWS.Cells(1, 6) = "Sum of Expense 2"

    'fill data in table        
    targetRow = 2    '-->targetRow will keep the counter for new row in Sheeet2

    'loop through unique values of Name through dict1
    For Each k1 In dict1.Keys
        count = 0
        'loop through unique No. ID through dict2 to match values in dict1 and dict2
        For Each k2 In dict2.Keys
            If k2 Like k1 & "*" Then    '-->match values of dict1 and dict2
                count = count + 1
                'fill data in table if match found
                targetWS.Cells(targetRow, 1) = k1
                targetWS.Cells(targetRow, 3) = k2
                targetWS.Cells(targetRow, 4) = dict2(k2)
                targetWS.Cells(targetRow, 5) = Application.WorksheetFunction.SumIf(Range("C2:C" & lastRow), k2, Range("D2:D" & lastRow))
                targetWS.Cells(targetRow, 6) = Application.WorksheetFunction.SumIf(Range("C2:C" & lastRow), k2, Range("E2:E" & lastRow))
                targetRow = targetRow + 1
            End If
        Next k2

       'fill data if no match found
        If count = 0 Then
            targetWS.Cells(targetRow, 1) = k1
            targetWS.Cells(targetRow, 3) = "-"
            targetWS.Cells(targetRow, 5) = 0
            targetWS.Cells(targetRow, 6) = 0
            targetRow = targetRow + 1
        End If
    Next k1

    'get values for Entry and Number of ID
    For i = 2 To targetWS.Cells(Rows.count, "A").End(xlUp).Row
        targetWS.Cells(i, 2) = Range("A:A").Find(What:=targetWS.Cells(i, 1), LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True).Offset(0, 1).Value
        targetWS.Cells(i, 4) = Application.WorksheetFunction.CountIf(targetWS.Range("A1:A" & lastRow), targetWS.Cells(i, 1))
    Next i
End Sub

注意：以上代码不会按照A1-A2-B3-B4-B5-B6-C0的升序显示数据，而是按照A1-A2-B4-B5-B6-B3-C0

等外观的顺序显示数据

参见图片以供参考：

Answer 2

修改后的代码在从同一个工作簿运行时起作用（与哪个工作表无关）。

为动态添加号码费用总和类型添加了一个数组。

此代码涵盖了按照您的意愿转换表格数据所需的逻辑。

Issues

Answer 3

您可以让VBA复制数据透视表数据并将其粘贴为普通表。

计算并汇总多个列中的唯一数据，然后将其与另一个唯一数据进行匹配

3 个答案: