如何用vba代码将B列相同的数据每5个合并为一行？

作者：绿色风分类：时间：2022-08-17 浏览：93

楼主
kevinchengcw

Q: 如何用vba代码将B列相同的数据每5个合并为一行？
A: 代码如下：

Sub testnew()
Dim Dic As Object, Dic2 As Object, Arr, Arr2, N&, I&
Set Dic = CreateObject("scripting.dictionary") '创建字典项目,Dic用于计数,Dic2用于记录对应的数组下标
Set Dic2 = CreateObject("scripting.dictionary")
Arr = [a1].Resize(Cells(Rows.Count, 1).End(3).Row, 2).Value '数据放入数组中
ReDim Arr2(0 To 1, 0) '初始化数组维数
Dic.Add Arr(1, 2), 1 '添加第一个数据并计数
Dic2.Add Arr(1, 2), 0 '添加第一个数据的对应数组下标
Arr2(1, 0) = Arr(1, 2) '添加第一个数据B列内容
Arr2(0, 0) = Arr(1, 1) '添加第一个数据A列内容
I = UBound(Arr2, 2) '初始化数组最后一维的下标最大值记录变量
For N = LBound(Arr) + 1 To UBound(Arr) '循环余下数据
If Dic.exists(Arr(N, 2)) And Dic(Arr(N, 2)) < 5 Then '如果字典中存在该B列项目,且计数值小于5,则
Arr2(0, Dic2(Arr(N, 2))) = Arr2(0, Dic2(Arr(N, 2))) & "," & Arr(N, 1) 'Arr2中对应B列内容的下标对应的内容以","分隔串接当前循环到的数据
Dic(Arr(N, 2)) = Dic(Arr(N, 2)) + 1 '对应项的计数值加1
Else '不存在的话
I = I + 1 '增加下标最大值加1
ReDim Preserve Arr2(0 To 1, 0 To I) '重新定义数组为新的下标最大值并保留原有数据
Dic(Arr(N, 2)) = 1 '对应项的计数置1
Dic2(Arr(N, 2)) = I '对应项的下标为下标最大值
Arr2(1, Dic2(Arr(N, 2))) = Arr(N, 2) '新增加的数组项写入当前循环到的内容
Arr2(0, Dic2(Arr(N, 2))) = Arr(N, 1)
End If
Next N
[f1].Resize(UBound(Arr2, 2) + 1, UBound(Arr2) + 1) = Application.Transpose(Arr2) '将数组转置到单元格区域
Set Dic = Nothing '清空字典项目
Set Dic2 = Nothing
End Sub

本例应用到如下技巧:
1. 字典在记录及查找数据时的高效率;
2. 数组redim的技巧;
3. 单元格区域与数组对应关系.

更多内容请参见素材源帖:
http://www.exceltip.net/thread-17427-1-2-21112.html

2楼
windimi007

学习一下K哥的思路！

免责声明

有感于原ExcelTip.Net留存知识的价值及部分知识具有的时间限定性因素，经与ExcelTip.Net站长Apolloh商议并征得其同意，现将原属ExcelTip.Net的知识帖采集资料于本站点进行展示，供有需要的人士查询使用，也慰缅曾经的论坛时代。所示各个帖子的原作者如对版权有异议，可与本人沟通提出，或于本站点留言，我们会尽快处理。在此，感谢ExcelTip.Net站长Apolloh的支持，感谢本站点所有人**绿色风（QQ:79664738)**的支持与奉献，特此鸣谢！
------本人网名**KevinChengCW（QQ:1210618015)**原ExcelTip.Net总版主之一

评论列表