如何用vba代码依各项分类生成结果报告表？

楼主 kevinchengcw	Q: 如何用vba代码依各项分类生成结果报告表？要实现结果见下图： A: 代码如下： Sub test() Dim Dic As Object, Dic2 As Object, Arr, Arr2, N&, I&, T&, Str$, Str2$, Str3$, Result, Rng As Range Set Dic = CreateObject("scripting.dictionary") '创建字典用于统计数据 Set Dic2 = CreateObject("scripting.dictionary") With Worksheets("数据") '在数据表中读取原始数据到数组中 Arr = .[a1].Resize(.Cells(.Rows.Count, 1).End(3).Row, .Cells(1, .Columns.Count).End(1).Column).Value End With With CreateObject("vbscript.regexp") '创建正则用于比较字段 .Global = True '全局有效 For N = LBound(Arr) + 1 To UBound(Arr) '循环原始数据中的数据区 Str = Arr(N, 3) & vbTab & Arr(N, 4) '组合专业名称与品牌字段（用于统计投放报社） Str2 = Str & "\|" & Arr(N, 1) & Arr(N, 5) & Arr(N, 6) '组合专业与品牌及投放情况字段（用于统计投放数据） If Dic.exists(Str) Then '如果已经存在该专业名称与品牌字段 .Pattern = "(^\|,)" & Arr(N, 1) & "(?=,\|$)" '将报社名设置成匹配规则用于判断是否已存在 If Not .test(Dic(Str)) Then Dic(Str) = Dic(Str) & "," & Arr(N, 1) '如果不存在该报社则更新对应字典项目 Else Dic(Str) = Arr(N, 1) '不存在的话，则添加该字典项目 End If If Dic2.exists(Str2) Then '如果存在该投放数据，则增加统计数据 Dic2(Str2) = Dic2(Str2) + 1 Else '如果不存在则添加 Dic2(Str2) = 1 End If Next N End With ReDim Result(1 To Dic.Count + 1, 1 To 4) '根据上面取得的结果重设结果数组（含标题行） Result(1, 1) = "专业名称": Result(1, 2) = "媒体名称": Result(1, 3) = "品牌": Result(1, 4) = "投放情况" '给标题行赋值 Arr = Dic.keys '将专业名称与品牌字段输出到数组中，便于依序提取 I = 2 '结果表中数据起始行 For N = LBound(Arr) To UBound(Arr) '循环结果数据各项 Arr2 = Split(Arr(N), vbTab) '拆分开专业名称与品牌方便写入结果数组中 Result(I, 1) = Arr2(0) '将对应各项写入结果表中 Result(I, 3) = Arr2(1) Result(I, 2) = Dic(Arr(N)) Arr2 = Dic2.keys '将投放情况提取出来 Str3 = "" '投放情况字符串初始化 For T = LBound(Arr2) To UBound(Arr2) '循环投放情况统计 If Arr2(T) Like Arr(N) & "\|*" Then '如果当前循环到的投放情况字头与当前数据结果一致，则进行数据处理 If Str3 <> "" Then Str3 = Str3 & "," '判断并添加分隔逗号 Str3 = Str3 & "投放" & Split(Arr2(T), "\|")(1) & Dic2(Arr2(T)) & "期" '提取对应数据并串接为投放情况结果字符串 Dic2.Remove Arr2(T) '移除以统计过的字典项目 End If Next T Result(I, 4) = Str3 '投放结果写入对应位置 I = I + 1 '下移一行 Next N With Worksheets("结果") '到结果表中处理结果 .Cells.Clear '清空原有数据 With .[a1].Resize(UBound(Result), UBound(Result, 2)) '根据结果数组确定写入范围 .Value = Result '写入结果数组 .EntireColumn.AutoFit '列宽自适应 Dic.RemoveAll '清空字典内容，用于处理后期同列相同内容单元格合并 For I = 1 To 2 '循环需要处理的列号 For Each Rng In Intersect(.Cells.Offset(1), .Cells, .Parent.Columns(I)) '循环结果数据中当前处理列的除标题行外的各个单元格 If Dic.exists(Rng.Value) Then '如果已经有这个字典项目 Set Dic(Rng.Value) = Union(Dic(Rng.Value), Rng) '将当前单元格合并到字典对应项的item中（单元格区域） Else Set Dic(Rng.Value) = Rng '否则将当前单元格值对应的字典item项 End If Next Rng Next I Arr = Dic.keys '取得字典中的各项 On Error Resume Next '防止操作单元格时出错，进行容错处理 Application.DisplayAlerts = False '禁止警告信息（防止合并单元格时的提示消息框） For N = LBound(Arr) To UBound(Arr) '循环字典各项 For Each Rng In Dic(Arr(N)).Areas '循环当前循环项中对应的字典item对应的单元格区域的各个区域 If Rng.Cells.Count > 1 Then Rng.Merge '如果区域中单元格超过1个，则进行合并 Next Rng Next N Application.DisplayAlerts = True '恢复显示警告信息 .Borders.LineStyle = 1 '结果数据加上边框线 End With End With Set Dic = Nothing '清空项目 Set Dic2 = Nothing End Sub 详见附件及素材源帖。依各项分类生成结果报告表.rar
2楼大元帅的双刃剑	[code]Sub Macro1() Dim d As Object, k, t, arr, brr(), i&, j%, m&, s$ Set d = CreateObject("scripting.dictionary") arr = Sheets("数据").[a1].CurrentRegion ReDim brr(1 To UBound(arr), 1 To 4) For i = 2 To UBound(arr) s = arr(i, 3) & arr(i, 4) If Not d.Exists(s) Then m = m + 1 d(s) = m brr(m, 1) = arr(i, 3) brr(m, 2) = arr(i, 1) brr(m, 3) = arr(i, 4) brr(m, 4) = arr(i, 1) & arr(i, 6) & arr(i, 5) Else brr(d(s), 2) = brr(d(s), 2) & "," & arr(i, 1) brr(d(s), 4) = brr(d(s), 4) & "," & arr(i, 1) & arr(i, 6) & arr(i, 5) End If Next For i = 1 To m d.RemoveAll a = Split(brr(i, 4), ",") For j = 0 To UBound(a) d(a(j)) = d(a(j)) + 1 Next k = d.keys t = d.items s = "" For j = 0 To d.Count - 1 s = s & "，投放" & k(j) & t(j) & "期" Next brr(i, 4) = Mid(s, 2) Next Application.ScreenUpdating = False Application.DisplayAlerts = False ActiveSheet.UsedRange.Offset(1).Clear With [a2].Resize(m, 4) .Value = brr .Sort Key1:=[a2].Resize(m), Order1:=xlAscending ' 以防Sheets("数据")中的“专业名称”相同字段不在一起 .Borders.LineStyle = 1 arr = .Value End With For i = m - 1 To 1 Step -1 If arr(i, 1) = arr(i + 1, 1) Then Cells(i + 1, 1).Resize(2).Merge Next Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub 高难度VBA语言请求2a.rar
3楼打滚的蛋饼	收藏下
4楼 gysegz	kevinchengcw版主你真牛！支持，顶起**