[已解决]【需要把单条的记录有选择性的，按一定条件和格式进行汇总，求助】

daxiaotong · 发表于 2014-4-12 15:21

请看附件，需要把单条的记录按“队号”合并在一起进行汇总上报。求助VBA高手。诚恳的希望帮助解决难题，并希望能附上注释说明，好让小弟学习研究，谢谢！

汇总单条数据.rar (12.52 KB, 下载次数: 3)

dsmch · 发表于 2014-4-12 15:47

………………

dsmch · 发表于 2014-4-12 15:55

Sub Macro1()
Dim arr, brr, d, d2, i&, s&
Set d = CreateObject("scripting.dictionary") '判断队号
Set d2 = CreateObject("scripting.dictionary") '判断同一队号的数量
arr = Sheet1.Range("a1").CurrentRegion '单元格赋值数组
ReDim brr(1 To UBound(arr), 1 To 11)
For i = 2 To UBound(arr) '数组循环
d2(arr(i, 4)) = d2(arr(i, 4)) + 1 '同一队号数量累加
If Not d.exists(arr(i, 4)) Then '如果队号不存在则
s = s + 1 '序号
d(arr(i, 4)) = s '序号队号对应
brr(s, 1) = s '序号
brr(s, 2) = arr(i, 2) '时间
brr(s, 3) = arr(i, 4) '队号
brr(s, 4) = arr(i, 5) '位置
brr(s, 5) = d2(arr(i, 4)) & "." & arr(i, 13) '存在问题
brr(s, 7) = d2(arr(i, 4)) & "." & arr(i, 14) '整改
brr(s, 9) = arr(i, 8) '整改人
brr(s, 11) = arr(i, 7) '检查人
Else '如果队号存在，按其序号，分别对存在问题和整改方式连接字符串
brr(d(arr(i, 4)), 5) = brr(d(arr(i, 4)), 5) & " " & d2(arr(i, 4)) & "." & arr(i, 13)
brr(d(arr(i, 4)), 7) = brr(d(arr(i, 4)), 7) & " " & d2(arr(i, 4)) & "." & arr(i, 14)
End If
Next
Range("a2").Resize(s, UBound(brr, 2)) = brr '数组赋值单元格
End Sub

复制代码

daxiaotong · 发表于 2014-4-12 17:03

dsmch 发表于 2014-4-12 15:55

感谢您的帮助，我测试一下！

daxiaotong · 发表于 2014-4-12 17:06

dsmch 发表于 2014-4-12 15:55

十分感谢，注释文件也这么详细，学习了！！！

daxiaotong · 发表于 2014-4-16 20:28

dsmch 发表于 2014-4-12 15:55

真的感谢您的帮助。但是在使用中发现了一个问题，还得麻烦您帮助看一下：在队号和位置不同的情况下，汇总是分别进行汇总的，但是如果在不同的日期，去相同的队号和位置时，汇总的时候就忽略了日期，把队号和位置想通的汇总在一起了。我想要的结果是日期不同，队号和位置相同也要分开汇总。麻烦你了，看看能帮我改动一下吗？万分谢谢！
附件里面我进行了详细的说明，麻烦您了！！

汇总单条数据_报错.rar (13.46 KB, 下载次数: 2)

daxiaotong · 发表于 2014-4-17 10:47

dsmch 发表于 2014-4-12 15:55

很着急，能否麻烦您帮着再看看，再次感谢！

dsmch · 发表于 2014-4-17 12:53

Sub Macro1()
Dim arr, brr, d, d2, i&, s&, zf$
Set d = CreateObject("scripting.dictionary") '判断队号
Set d2 = CreateObject("scripting.dictionary") '判断同一队号的数量
arr = Sheet1.Range("a1").CurrentRegion '单元格赋值数组
ReDim brr(1 To UBound(arr), 1 To 11)
For i = 2 To UBound(arr) '数组循环
zf = arr(i, 2) & "," & arr(i, 4) '日期+队号
d2(zf) = d2(zf) + 1 '同一日期队号数量累加
If Not d.exists(zf) Then '如果队号不存在则
s = s + 1 '序号
d(zf) = s '序号队号对应
brr(s, 1) = s '序号
brr(s, 2) = arr(i, 2) '时间
brr(s, 3) = arr(i, 4) '队号
brr(s, 4) = arr(i, 5) '位置
brr(s, 5) = d2(zf) & "." & arr(i, 13) '存在问题
brr(s, 7) = d2(zf) & "." & arr(i, 14) '整改
brr(s, 9) = arr(i, 8) '整改人
brr(s, 11) = arr(i, 7) '检查人
Else '如果队号存在，按其序号，分别对存在问题和整改方式连接字符串
brr(d(zf), 5) = brr(d(zf), 5) & " " & d2(zf) & "." & arr(i, 13)
brr(d(zf), 7) = brr(d(zf), 7) & " " & d2(zf) & "." & arr(i, 14)
End If
Next
Range("a2").Resize(s, UBound(brr, 2)) = brr '数组赋值单元格
End Sub

复制代码

dsmch · 发表于 2014-4-17 12:54

………………

daxiaotong · 发表于 2014-4-17 14:46

dsmch 发表于 2014-4-17 12:54
………………

感谢您的再次帮助！perfact!!

		自动登录	找回密码
密码			注册

[已解决]【需要把单条的记录有选择性的，按一定条件和格式进行汇总，求助】

相关帖子