[已解决]如何合并数据及统计重复次数？

cashiba · 发表于 2012-1-4 15:46

想把大量数据合并整理，涉及到重复合并的一些问题，详情见附件，请老师们得空指点一二！

最佳答案

liuguansky

2012-1-4 16:14

速度还OK，我的配置的话，0.2S左右

Sub juSTTest()
Dim Arr, D As New Dictionary, At(1 To 2) As New Dictionary, K&, ArrT(1 To 10000, 1 To 5)
Dim i&, S$, Ar, j&, Akd, Ak, Ai, ASp, a As Byte, AStr(1 To 2) As String, t
t = Timer
Arr = Range("a1:e" & Cells(Rows.Count, 1).End(3).Row).Value
For i = 1 To UBound(Arr)
S = Arr(i, 1) & vbTab & Arr(i, 4) & vbTab & Arr(i, 5)
If D.Exists(S) Then
Ar = D(S)
If Ar(1).Exists(Arr(i, 2)) Then
Ar(1)(Arr(i, 2)) = Ar(1)(Arr(i, 2)) + 1
Else
Ar(1).Add Arr(i, 2), 1
End If
If At(2).Exists(Arr(i, 3)) Then
Ar(2)(Arr(i, 3)) = Ar(2)(Arr(i, 3)) + 1
Else
Ar(2).Add Arr(i, 3), 1
End If
D(S) = Ar
Else
Erase At
At(1).Add Arr(i, 2), 1
At(2).Add Arr(i, 3), 1
D.Add S, At
End If
Next
Akd = D.Keys
For i = 0 To UBound(Akd)
Ar = D(Akd(i))
For a = 1 To 2
Ak = Ar(a).Keys: Ai = Ar(a).Items
For j = 0 To UBound(Ak)
AStr(a) = AStr(a) & ";" & Ak(j) & "(" & Ai(j) & ")"
Next j
Next a
K = K + 1: ASp = Split(Akd(i), vbTab)
ArrT(K, 1) = ASp(0): ArrT(K, 4) = ASp(1): ArrT(K, 5) = ASp(2)
ArrT(K, 2) = Mid(AStr(1), 2)
ArrT(K, 3) = Replace(Mid(AStr(2), 2), ";", "_")
Next i
With Sheet2
.Range("a2:e" & .Rows.Count).ClearContents
.Range("A2").Resize(K, 5) = ArrT
.Activate
End With
MsgBox "处理完毕，用时" & Timer - t
Set D = Nothing
End Sub

复制代码

book2.rar (19.15 KB, 下载次数: 87)

liuguansky · 发表于 2012-1-4 16:14

速度还OK，我的配置的话，0.2S左右

Sub juSTTest()
Dim Arr, D As New Dictionary, At(1 To 2) As New Dictionary, K&, ArrT(1 To 10000, 1 To 5)
Dim i&, S$, Ar, j&, Akd, Ak, Ai, ASp, a As Byte, AStr(1 To 2) As String, t
t = Timer
Arr = Range("a1:e" & Cells(Rows.Count, 1).End(3).Row).Value
For i = 1 To UBound(Arr)
S = Arr(i, 1) & vbTab & Arr(i, 4) & vbTab & Arr(i, 5)
If D.Exists(S) Then
Ar = D(S)
If Ar(1).Exists(Arr(i, 2)) Then
Ar(1)(Arr(i, 2)) = Ar(1)(Arr(i, 2)) + 1
Else
Ar(1).Add Arr(i, 2), 1
End If
If At(2).Exists(Arr(i, 3)) Then
Ar(2)(Arr(i, 3)) = Ar(2)(Arr(i, 3)) + 1
Else
Ar(2).Add Arr(i, 3), 1
End If
D(S) = Ar
Else
Erase At
At(1).Add Arr(i, 2), 1
At(2).Add Arr(i, 3), 1
D.Add S, At
End If
Next
Akd = D.Keys
For i = 0 To UBound(Akd)
Ar = D(Akd(i))
For a = 1 To 2
Ak = Ar(a).Keys: Ai = Ar(a).Items
For j = 0 To UBound(Ak)
AStr(a) = AStr(a) & ";" & Ak(j) & "(" & Ai(j) & ")"
Next j
Next a
K = K + 1: ASp = Split(Akd(i), vbTab)
ArrT(K, 1) = ASp(0): ArrT(K, 4) = ASp(1): ArrT(K, 5) = ASp(2)
ArrT(K, 2) = Mid(AStr(1), 2)
ArrT(K, 3) = Replace(Mid(AStr(2), 2), ";", "_")
Next i
With Sheet2
.Range("a2:e" & .Rows.Count).ClearContents
.Range("A2").Resize(K, 5) = ArrT
.Activate
End With
MsgBox "处理完毕，用时" & Timer - t
Set D = Nothing
End Sub

复制代码

book2.rar (19.15 KB, 下载次数: 87)

bjjgq · 发表于 2012-1-4 16:32

A列和B列数据双击时，数据前面有个单引号
先解决一个小问题：这个引号没有问题，不会影响的，只是文本的标志
第一个大问题，等我想想吧
用vba肯定是可以解决，但要先想好算法才能少走弯路

cashiba · 发表于 2012-1-5 00:25

liuguansky 发表于 2012-1-4 16:14
速度还OK，我的配置的话，0.2S左右

liuguansky老师，好像不行噢，合并后得到的结果，每行的B列、C列几乎都变成一样的了.....

还有运行时错误“1004”

错误在
With Sheet2
      .Range("a2:e" & .Rows.Count).ClearContents
      .Range("A2").Resize(K, 5) = ArrT
      .Activate
End With

cashiba · 发表于 2012-1-5 00:28

bjjgq 发表于 2012-1-4 16:32
A列和B列数据双击时，数据前面有个单引号
先解决一个小问题：这个引号没有问题，不会影响的，只是文本的标 ...

谢谢bjjgq 老师，多费心了~

liuguansky · 发表于 2012-1-5 09:00

cashiba 发表于 2012-1-5 00:25
liuguansky老师，好像不行噢，合并后得到的结果，每行的B列、C列几乎都变成一样的了.....

还有运行 ...

31行代码前添加一句

复制代码

至于你说的错误，倒没有发现。

cashiba · 发表于 2012-1-5 13:02

谢谢版主liuguansky老师，速度很快，很好用。这么多代码你一蹴而就，佩服佩服！

Select · 发表于 2012-1-5 15:30

cashiba 发表于 2012-1-5 13:02
谢谢版主liuguansky老师，速度很快，很好用。这么多代码你一蹴而就，佩服佩服！

如果楼主问题解决了，最好给评下最佳

bjjgq · 发表于 2012-1-5 17:02

liuguansky老师厉害，使用了字典，认真学习啦

cashiba · 发表于 2012-1-5 22:32

bjjgq 发表于 2012-1-5 17:02
liuguansky老师厉害，使用了字典，认真学习啦

好多变量，多字典组合，不过速度确实狠快，可惜对字典、数组似懂非懂的，看不大明白{:181:}，如果有谁能注解一下就好了.....

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