Excel VBA使用分组值创建报告

我正在尝试使用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

功能唯一性（r作为范围）
尺寸d作为对象，c作为范围，tmp
Set d=CreateObject（“scripting.dictionary”）
对于RCELL中的每个c
tmp=微调（c值）
如果Len（tmp）>0，则
如果不存在d.Exists（tmp）和tmp“HEADER”，则d.添加tmp，1
如果结束
下一个c
Uniques=d.keysEnd函数
带.Range（“A1:N”和.Cells（.Rows.Count，1）.End（xlUp.Row）
.自动筛选字段：=1
设置a=.Columns（“a”）.Offset（1）.调整大小（.Rows.Count-1）.特殊单元格（xlCellTypeVisible）
设置b=.Columns（“b”）.Offset（1）.调整大小（.Rows.Count-1）.特殊单元格（xlCellTypeVisible）
'获取唯一的项目
d=唯一（范围（“d:d”）。特殊单元格（xlCellTypeVisible））
.自动过滤器
以

使用dictionary的方法是朝着正确的方向迈出的一步，尽管它还需要1个dictionary对象才能在子循环中使用它。它变得有点复杂和有趣，因为问题中的预期摘要部分指出了额外的列以及对唯一和排序数据的要求

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

第二版：

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

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

---

它可以工作，但有时C列“number”不能正确地写在它的“name”旁边，它被单独添加为末尾的新行。如果我需要添加更多列并仍然使用此函数，是否可以指出需要更改的列变量的位置？现在谢谢你了？我将C列简化为

表格（2）。单元格（i+1,3）=colToRw（r）

和D列简化为

表格（2）。单元格（i+1,4）=colToRw（r）

。其他列为：A列=

表格（2）。单元格（i+1，1）=d（k）

，B列=

表格（2）。单元格（i+1，2）=k

，&col E=

如果j=0，则表格（2）。单元格（i+1，5）=cmnt

，谢谢。它起作用了。我现在刚刚遇到了将C列更新为H列的问题，当我更改它时，它会在r.Sort r.Columns（1）“Range类的Sort方法失败”中抛出一个错误。H列的编号与示例表中的C列相同。我是否应该更改任何其他值以使其使用H列而不是C列工作？它只填充“，，，，，，”r似乎为空。我已把你的答案标为解决办法。谢谢，不客气。由于您需要以相同的方式处理其他列，因此我添加了第二个版本，其中您可能会提到列#。e、 g.

Sheets（2）.单元格（i+1，3）=UniqSensor（k，rng，1，d.Count）

用于C列和

Sheets（2）.单元格（i+1，4）=UniqSensor（k，rng，2，d.Count）

用于d列，依此类推。注意，我们只需要在两个地方进行更改。这两个地方在哪里？

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