Excel VBA使用分组值创build报表
我正在尝试在Excel中使用VBA创build一个报表来处理一些数据，并创build一个表格报告，按组来汇总值。 尽pipe我可以手动生成表格，但是我无法获得完整创build此报表的代码。
input数据：
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
使用字典的方法是朝正确的方向迈出的一步，尽pipe它需要1个字典对象在子循环中使用它。 由于附加列以及在问题的预期摘要部分中指出的唯一和sorting数据的要求，它变得有点复杂和有趣。
下面更新的代码假定macros从包含此数据的工作表触发，并生成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
第二版：
基于随后的讨论，这里是一个更加实用的方法的修改和精简版本。 在这种方法下，可以在function调用中设置需要search有序唯一列表的列。
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