重复数据合并（不是简单的去重需累加和计算）请高人指点

81818000

重复数据合并（不是简单的去重需累加和计算）请高人指点，需要从“基础数据”自动生成“结果"表。 test.rar (6.86 KB, 下载次数: 25)

2014-5-20 09:19 上传

点击文件名下载附件

office8424

Sub aa()
Range("A2:C10000").Clear
Set dic = CreateObject("scripting.dictionary")
With Sheets("基础数据")
For i = 2 To .[a65536].End(3).Row
dic(.Cells(i, 1).Value) = dic(.Cells(i, 1).Value) & "、" & .Cells(i, 2).Value
Next i
Range("A2").Resize(dic.Count, 2) = Application.Transpose(Array(dic.keys, dic.items))
dic.RemoveAll
For j = 2 To [b65536].End(3).Row
Cells(j, 2) = Right(Cells(j, 2).Value, Len(Cells(j, 2).Value) - 1)
Cells(j, 3) = Application.WorksheetFunction.SumIf(.Range("A1:A10000"), Cells(j, 1), .Range("C1:C10000"))
Next j
End With
End Sub

mineshine

仅供参考

1. 
   
2. Sub test()
   
3.     Dim i As Long, r As Long
   
4.     Dim arr, brr, a, c, fadd$, dic As Object
   
5.     Dim S1 As Worksheet, S2 As Worksheet
   
6.     Set S1 = Sheets("基础数据")
   
7.     Set S2 = Sheets("结果")
   
8.     arr = S1.[a1].CurrentRegion
   
9.     Set dic = CreateObject("scripting.dictionary")
   
10.     For i = 2 To UBound(arr)
    
11.         If Not dic.exists(arr(i, 1) & "") Then dic.Add arr(i, 1), ""    '不重复姓名
    
12.     Next i
    
13.     ReDim brr(1 To dic.Count, 1 To 3)
    
14.     a = dic.keys
    
15.     For i = 0 To dic.Count - 1
    
16.         brr(i + 1, 1) = a(i)    '姓名
    
17.         With Sheet1.Columns(1)
    
18.             Set c = .Find(a(i), LookIn:=xlValues, lookat:=xlWhole)
    
19.             If Not c Is Nothing Then
    
20.                 fadd = c.Address
    
21.                 Do
    
22.                     n = n + c.Offset(, 2)   '数量
    
23.                     If Rng = "" Then
    
24.                         Rng = c.Offset(, 1)
    
25.                     Else
    
26.                         Rng = Rng & "、" & c.Offset(, 1)    '书名
    
27.                     End If
    
28.                     Set c = .FindNext(c)
    
29.                 Loop While Not c Is Nothing And c.Address <> fadd
    
30.                 brr(i + 1, 2) = Rng     '书名
    
31.                 brr(i + 1, 3) = n       '数量
    
32.                 Rng = "": n = 0
    
33.             End If
    
34.         End With
    
35.     Next i
    
36.     r = S2.Cells(S2.Rows.Count, 1).End(xlUp).Row + 1 '结果最后空白列
    
37.     S2.Cells(r, 1).Resize(dic.Count, 3) = brr
    
38. End Sub
    

复制代码

蓝桥玄霜

1. Sub lqxs()
   
2. Dim Arr, i&, Brr, j&, aa, n&
   
3. Dim d, k, t
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. Sheet2.Activate
   
6. [a2:c5000].ClearContents
   
7. Arr = Sheet1.[a1].CurrentRegion
   
8. For i = 2 To UBound(Arr)
   
9.     d(Arr(i, 1)) = d(Arr(i, 1)) & i & ","
   
10. Next
    
11. k = d.keys: t = d.items
    
12. ReDim Brr(1 To d.Count, 1 To 3)
    
13. For i = 0 To UBound(k)
    
14.     t(i) = Left(t(i), Len(t(i)) - 1)
    
15.     If InStr(t(i), ",") Then
    
16.         aa = Split(t(i), ",")
    
17.         n = n + 1
    
18.         Brr(n, 1) = k(i)
    
19.         For j = 0 To UBound(aa)
    
20.             If j = 0 Then
    
21.                 Brr(n, 2) = Arr(aa(j), 2): Brr(n, 3) = Arr(aa(j), 3)
    
22.             Else
    
23.                 Brr(n, 2) = Brr(n, 2) & "、" & Arr(aa(j), 2): Brr(n, 3) = Brr(n, 3) + Arr(aa(j), 3)
    
24.             End If
    
25.         Next
    
26.     Else
    
27.         n = n + 1
    
28.         Brr(n, 1) = k(i): Brr(n, 2) = Arr(t(i), 2): Brr(n, 3) = Arr(t(i), 3)
    
29.     End If
    
30. Next
    
31. [a2].Resize(n, 3) = Brr
    
32. End Sub
    

复制代码

蓝桥玄霜

请见附件。

suyunlong123

Sub niwo()
Dim arr
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
arr = Range("a1").CurrentRegion
For i = 1 To UBound(arr)
d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 3)
d1(arr(i, 1)) = d1(arr(i, 1)) & "," & arr(i, 2)
Next
For Each ch In d1.keys
d1(ch) = Mid(d1(ch), 2, Len(d1(ch)) - 1)
Next
With Sheet2
.Range("a1").Resize(d.Count, 1) = Application.Transpose(d.keys)
.Range("b1").Resize(d.Count, 1) = Application.Transpose(d1.items)
.Range("c1").Resize(d.Count, 1) = Application.Transpose(d.items)
End With
End Sub

chxw68

呵呵，对这个问题比较有兴趣，也来凑凑热闹练练手。

1. Sub test()
   
2.   Dim d As Object
   
3.   Dim r%, i%
   
4.   Dim arr, brr
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   With Worksheets("基础数据")
   
7.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.     arr = .Range("a2:c" & r)
   
9.   End With
   
10.   For i = 1 To UBound(arr)
    
11.     If Not d.Exists(arr(i, 1)) Then
    
12.       d(arr(i, 1)) = Array(arr(i, 1), arr(i, 2), arr(i, 3))
    
13.     Else
    
14.       brr = d(arr(i, 1))
    
15.       brr(1) = brr(1) & "、" & arr(i, 2)
    
16.       brr(2) = brr(2) + arr(i, 3)
    
17.       d(arr(i, 1)) = brr
    
18.     End If
    
19.   Next
    
20.   With Worksheets("结果")
    
21.     .UsedRange.Offset(1, 0).ClearContents
    
22.     .Range("a2").Resize(d.Count, 3) = Application.Transpose(Application.Transpose(d.Items))
    
23.   End With
    
24. End Sub
    

复制代码

chxw68

纯属练手。

hlly888

1. Sub yy()
   
2. Sheet2.[a2:c65536].ClearContents
   
3. Dim da As Object, arr, i&, w, s, q(1 To 10)
   
4. Set da = CreateObject("Scripting.Dictionary")
   
5. arr = Sheet1.[a1].CurrentRegion
   
6. ReDim Brr(1 To UBound(arr), 1 To 3)
   
7. For i = 2 To UBound(arr)
   
8.     w = da(arr(i, 1))
   
9.     If w = "" Then
   
10.        s = s + 1
    
11.        Brr(s, 1) = arr(i, 1)
    
12.        Brr(s, 2) = Brr(s, 2) & arr(i, 2)
    
13.        da(arr(i, 1)) = s
    
14.        w = s
    
15.        q(w) = q(w) & "、" & Brr(s, 2)
    
16.     End If
    
17.     If InStr(q(w), arr(i, 2)) = 0 Then Brr(w, 2) = Brr(w, 2) & "、" & arr(i, 2)
    
18.     Brr(w, 3) = Brr(w, 3) + arr(i, 3)
    
19.     q(w) = q(w) & "、" & Brr(w, 2)
    
20. Next
    
21. [a2].Resize(s, 3) = Brr
    
22. End Sub

复制代码

hlly888

bnm.rar (22.77 KB, 下载次数: 16)

2014-5-20 22:59 上传

点击文件名下载附件