楼主
kevinchengcw |
Q: 如何利用vba代码通过表格数据整理实现分类汇总效果？
A: 代码如下：
- Sub test()
- Dim Rng As Range, Rng2 As Range, Ws As Worksheet, N&, I&, Dic As Object, Str$
- Application.ScreenUpdating = False '关闭屏幕刷新,因有大量的Range对象操作,这样可以提高执行速度
- Set Ws = Worksheets("数据源") '将数据源工作表赋值给变量,方便后面调用
- Worksheets.Add '添加一个新的工作表(注意:新添加的工作表会被激活)
- With ActiveSheet '在活动工作表中进行操作(即我们上一句新添加的工作表)
- .Range(Ws.UsedRange.Address) = Ws.UsedRange.Value '将数据源工作表中的数据通过引值方式引入(排除了格式及公式等)
- Set Rng = .Rows(1).Find("物料单") '在标题行查找"物料单"对应的单元格,用于定位使用
- Set Rng2 = .Rows(1).Find("本位币金额") '在标题行查找"本位币金额"对应的单元格,用于定位使用
- Intersect(.UsedRange, .Rows("2:" & .Rows.Count)).Sort key1:=Rng.Offset(1) '对数据区(无标题行)依人名排序
- For N = .Cells(1, .Columns.Count).End(1).Column To 1 Step -1 '从右向左,删除不需要的数据列
- If InStr(",物料编码,物料描述,物料单,数量,本位币金额,", "," & Trim(.Cells(1, N).Value) & ",") = 0 Then .Columns(N).Delete
- Next N
- I = .Cells(.Rows.Count, Rng.Column).End(3).Row '取得名字列的最下行行标
- For N = 2 To I '循环将"物料编码","物料描述","物料单"三列每行的内容以特定字符组合(便于合并计算)后放到A列里,并清空后面两列内容(便于后面分列时不出现提示)
- .Cells(N, 1) = .Cells(N, 1).Value & vbTab & .Cells(N, 2).Value & vbTab & .Cells(N, 3).Value
- .Cells(N, 2) = ""
- .Cells(N, 3) = ""
- Next N
- With Intersect(.Columns("a:e"), .Rows("2:" & .Rows.Count)) '对数据区内容进行合并计算,结果放到与数据区相领的右侧
- .Parent.[f2].Consolidate Sources:=.Address(ReferenceStyle:=xlR1C1), Function:=xlSum, leftcolumn:=True
- .Delete xlToLeft '删除旧的数据区(右侧单元格左移),这样合并计算后的结果会占据原来数据区的位置
- End With
- .Range("a2:a" & .Cells(.Rows.Count, 1).End(3).Row).TextToColumns Tab:=True '对合并的数据区域进行分列处理,恢复数据格式原貌
- I = .Cells(.Rows.Count, Rng.Column).End(3).Row '取得当前姓名列的最后行号
- For N = I To 2 Step -1 '从后向前循环
- If .Cells(N, Rng.Column).Value <> .Cells(N - 1, Rng.Column).Value Then '如果当前循环到的行的姓名与上一行不同,则
- .Rows(N & ":" & N + 2).Insert '从当前行开始,插入三行
- .Cells(I + 4, Rng2.Column).FormulaR1C1 = "=sum(R" & N + 3 & "C:R" & I + 3 & "C)" '在当前姓名范围的右下方对应数据区写入加和公式,统计出合计值
- .Rows(N + 2) = .Rows(1).Value '插入的最后一行引用标题行内容
- .Cells(N + 1, 1) = .Cells(N + 3, Rng.Column).Value & "领料清单" '插入的第二行写入汇总的含姓名的标题
- I = N - 1 '更新数据区最下方行数值
- End If
- Next N
- .Columns(Rng.Column).Delete '删除姓名列
- .Columns.AutoFit '列宽自适应
- .Rows("1:2").Delete '删除多余的标题行
- End With
- Application.ScreenUpdating = True '打开屏幕刷新
- End Sub
详见附件及素材源帖.
 vba代码实现分类汇总.rar
|