Excel VBA 创建具有分组值的报告

Question

我正在尝试使用 VBA 在 Excel 中创建一个报告来处理一些数据并创建一个表格报告，按组汇总值。虽然我可以手动生成表格，但我无法获取完全创建此报告的代码。

输入数据:

ID | name   | number | class | comment
---|--------|--------|-------|----------       
 1 | john   |      4 | A1    | sports
---|--------|--------|-------|----------      
 1 | john   |      3 | A2    | sports
---|--------|--------|-------|----------      
 1 | john   |      5 | A3    | sports
---|--------|--------|-------|----------      
 2 | charly |      1 | B3    | tech
---|--------|--------|-------|----------     
 2 | charly |      2 | B2    | tech
---|--------|--------|-------|----------  
 2 | charly |      1 | B2    | tech
---|--------|--------|-------|----------   
 3 | frank  |      7 | C3    | language
---|--------|--------|-------|----------     
 3 | frank  |      2 | C5    | language
---|--------|--------|-------|----------  
 3 | frank  |      9 | C4    | language

新工作表中的预期摘要:

ID | name   | number  | class      | comment
---|--------|---------|------------|----------
 1 | john   | ”3,4,5” | ”A1,A2,A3” | sports
---|--------|---------|------------|----------
 2 | charly | ”1,2”   | ”B2,B3”    | tech
---|--------|---------|------------|----------
 3 | frank  | ”2,7,9” | ”C3,C4,C5” | language

这是我目前拥有的代码:

Function Uniques(r As Range)

Dim d As Object, c As Range, tmp
     Set d = CreateObject("scripting.dictionary")
     For Each c In rCells
        tmp = Trim(c.Value)
        If Len(tmp) > 0 Then
             If Not d.Exists(tmp) And tmp <> “HEADER” Then d.Add tmp, 1
        End If
     Next c
     Uniques = d.keysEnd Function
     With .Range("A1:N" & .Cells(.Rows.Count, 1).End(xlUp).Row)
           .AutoFilter Field:=1
           Set a = .Columns(“A”).Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
           Set b = .Columns(“B”).Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
           'getting the unique items
            d = Uniques(Range("D:D").SpecialCells(xlCellTypeVisible))
           .AutoFilter
     End With

Answer 1

使用字典的方法是朝着正确方向迈出的一步，尽管它需要 1 个以上的字典对象才能在子循环中使用它。由于附加列以及问题中预期摘要部分所示的唯一和排序数据的要求，它变得有点复杂和有趣。

下面更新的代码假定宏是从包含此数据的工作表中触发的，并在 Sheet(2) 中生成输出:

Sub strSplit()
    Dim r As Range, lastRow As Long, k As Variant, k1 As Variant, d As Object, d1 As Object, i As Long, j As Long, cmnt As String
    Set d = CreateObject("Scripting.Dictionary")
    Set d1 = CreateObject("Scripting.Dictionary")
    lastRow = Cells(Rows.Count, 1).End(xlUp).Row
    For Each r In Range("B2:B" & lastRow)
        If Not IsEmpty(r) Then d(r.Value) = r.Offset(0, -1).Value
    Next
    For Each k In d.Keys
        i = i + 1
        Sheets(2).Cells(i + 1, 1) = d(k)
        Sheets(2).Cells(i + 1, 2) = k

        'get list of unique numbers for each ID + comment
        For Each r In Range("B2:B" & lastRow)
            If k = r.Value Then
                d1(r.Offset(0, 1).Value) = r.Value
                cmnt = r.Offset(0, 3).Value
            End If
        Next
        j = 0
        For Each k1 In d1.Keys
            If j = 0 Then Sheets(2).Cells(i + 1, 5) = cmnt
            Sheets(2).Cells(j + d.Count + 2, 3) = k1
            j = j + 1
        Next
        Set r = Sheets(2).Range("C" & d.Count + 2 & ":C" & j + 1 + d.Count)
        r.Sort r.Columns(1)
        Sheets(2).Cells(i + 1, 3) = colToRw(r)
        r.ClearContents
        d1.RemoveAll

        'get list of unique classes for each ID
        For Each r In Range("B2:B" & lastRow)
            If k = r.Value Then d1(r.Offset(0, 2).Value) = r.Value
        Next
        j = 0
        For Each k1 In d1.Keys
            Sheets(2).Cells(j + d.Count + 2, 4) = k1
            j = j + 1
        Next
        Set r = Sheets(2).Range("D" & d.Count + 2 & ":D" & j + 1 + d.Count)
        r.Sort r.Columns(1)
        Sheets(2).Cells(i + 1, 4) = colToRw(r)
        r.ClearContents
        d1.RemoveAll
    Next
    Sheets(2).Select
End Sub
Function colToRw(r As Range) As String
    Dim r1 As Range, is1st As Boolean
    is1st = True
    For Each r1 In r
        If Not is1st Then
            colToRw = colToRw & ", "
        Else: is1st = False
        End If
        colToRw = colToRw & r1.Value
    Next
End Function

第二版:

基于随后的讨论，这里有一个经过修改和精简的版本，具有更实用的方法。在这种方法下，可以在函数调用中设置需要搜索有序且唯一列表的列。

Sub strSplit()
    Dim r As Range, lastRow As Long, rng As Range, k As Variant, d As Object, i As Long
    Set d = CreateObject("Scripting.Dictionary")
    lastRow = Cells(Rows.Count, 1).End(xlUp).Row
    Set rng = Range("B2:B" & lastRow)
    For Each r In rng
        If Not IsEmpty(r) Then d(r.Value) = r.Offset(0, -1).Value
    Next
    For Each k In d.Keys
        i = i + 1
        Sheets(2).Cells(i + 1, 1) = d(k) 'column 1
        Sheets(2).Cells(i + 1, 2) = k 'column 2
        For Each r In rng
            If k = r.Value Then
                Sheets(2).Cells(i + 1, 5) = r.Offset(0, 3).Value 'column 5
                Exit For
            End If
        Next
        Sheets(2).Cells(i + 1, 3) = uniqNsort(k, rng, 1, d.Count) 'column 3
        Sheets(2).Cells(i + 1, 4) = uniqNsort(k, rng, 2, d.Count) 'column 4
    Next
    Sheets(2).Select
End Sub
Function uniqNsort(k, rng As Range, rngOffsetCol As Long, rwNo As Long) As String 'get ordered list of unique items
    Dim k1, r As Range, i As Long, d As Object
    Set d = CreateObject("Scripting.Dictionary")
    For Each r In rng
        If k = r.Value Then
            d(r.Offset(0, rngOffsetCol).Value) = r.Value
        End If
    Next
    For Each k1 In d.Keys
        Sheets(2).Cells(i + rwNo + 2, 1) = k1
        i = i + 1
    Next
    Set r = Sheets(2).Range("A" & rwNo + 2 & ":A" & rwNo + i + 1)
    r.Sort r.Columns(1)
    uniqNsort = colToRw(r)
    r.ClearContents
End Function
Function colToRw(r As Range) As String
    Dim r1 As Range, is1st As Boolean
    is1st = True
    For Each r1 In r
        If Not is1st Then
            colToRw = colToRw & ", "
        Else: is1st = False
        End If
        colToRw = colToRw & r1.Value
    Next
End Function