关于数据合并，求助各路神仙

熙尊

各路大神看一下，对您们应该不难！

lsc900707

1. Sub gj23w98()
   
2.     Dim arB()
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     arA = Sheet1.[A1].CurrentRegion
   
5.     For i = 2 To UBound(arA)
   
6.         If Not d.exists(arA(i, 1)) Then
   
7.             n = n + 1
   
8.             d(arA(i, 1)) = n
   
9.             ReDim Preserve arB(1 To 3, 1 To n)
   
10.             For j = 1 To 3
    
11.                 arB(j, n) = arA(i, j)
    
12.             Next
    
13.         Else
    
14.             m = d(arA(i, 1))
    
15.             arB(3, m) = arB(3, m) & "," & arA(i, 3)
    
16.         End If
    
17.     Next
    
18.     [a2].Resize(n, 3) = Application.Transpose(arB)
    
19. End Sub

复制代码

lsc900707

附件供参考：

abc123281

1. Sub test()
   
2.     Dim arr
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     Set d1 = CreateObject("scripting.dictionary")
   
5.     With Worksheets("sheet1")
   
6.         arr = .Range("a2:c" & .Cells(.Rows.Count, 1).End(3).Row)
   
7.         For i = 1 To UBound(arr)
   
8.           mx = arr(i, 1) & "*" & arr(i, 2)
   
9.           mn = arr(i, 1) & "*" & arr(i, 2)
   
10.           d1(mn) = Array(arr(i, 1), arr(i, 2))
    
11.           If Not d.exists(mx) Then
    
12.              d(mx) = arr(i, 3)
    
13.           Else
    
14.              d(mx) = d(mx) & "，" & arr(i, 3)
    
15.           End If
    
16.         Next
    
17.     End With
    
18.     With Worksheets("sheet2")
    
19.       .[a2:c1000].ClearContents
    
20.       .[a2].Resize(d1.Count, 2) = Application.Transpose(Application.Transpose(d1.items))
    
21.       .[c2].Resize(d.Count, 1) = Application.Transpose(d.items)
    
22.    End With
    
23. End Sub

复制代码

abc123281

数据合并abc123.rar (24.03 KB, 下载次数: 1)

2018-4-8 13:39 上传

点击文件名下载附件

jiangxiaoyun

Sub vv()
    Dim arr
    arr = Sheet1.[a1].CurrentRegion
    Set d = CreateObject("scripting.dictionary")
    k = 1
    For i = 2 To UBound(arr)
        s = arr(i, 1) & arr(i, 2)
        If Not d.exists(s) Then
            k = k + 1
            d(s) = k
            For j = 1 To 3
                arr(k, j) = arr(i, j)
            Next
        Else
            If InStr(d(s), arr(i, 2)) = 0 Then
                arr(d(s), 3) = arr(d(s), 3) & "," & arr(i, 3)
            End If
        End If
    Next
    Sheet2.Cells.ClearContents
    Sheet2.[a1].Resize(k, 3) = arr
End Sub

jiangxiaoyun

数据合并.zip (26.76 KB, 下载次数: 3)

2018-4-8 13:53 上传

点击文件名下载附件

熙尊

lsc900707 发表于 2018-4-8 13:30
附件供参考：

您的这个我看了，还是有一点问题的，如果物品费用一样，续重费用不一样，也会合并到一起！烦劳大神可以在改下吗？