如何使用宏来查找匹配数据

shengxu90

一个供应商对应多个物料大类和小类，如何达到表2的效果。

供应商名称	物料大类	物料小类		供应商名称	物料大类	物料小类
中亿达金属科技（常州）有限公司	标准件	垫圈		中亿达金属科技（常州）有限公司	标准件	垫圈/机械标准其他/螺钉
中亿达金属科技（常州）有限公司	标准件	机械标准其他		中策橡胶集团有限公司	轮胎	外胎
中亿达金属科技（常州）有限公司	标准件	螺钉		郑州比克电池有限公司	电池	电芯
中策橡胶集团有限公司	轮胎	内胎		浙江星联电动自行车零件有限公司	标准件/电控定制类/硅胶/橡胶	电控标准其他/刹把/其他/硅胶类
中策橡胶集团有限公司	轮胎	外胎
郑州比克电池有限公司	电池	电芯
浙江星联电动自行车零件有限公司	标准件	电控标准其他
浙江星联电动自行车零件有限公司	电控定制类	刹把
浙江星联电动自行车零件有限公司	电控定制类	其他
浙江星联电动自行车零件有限公司	硅胶/橡胶	硅胶类
浙江联和电子有限公司	标准件	连接/接插类
张家港市昊海电子有限公司	电控定制类	其他
增你强(上海)国际贸易有限公司	标准件	二极管
增你强(上海)国际贸易有限公司	关键元器件	IC
源文兴车料（太仓）有限公司	铃铛	铃铛

mhy2018

之前不是有人解答了吗

shengxu90

mhy2018 发表于 2018-8-21 13:33
之前不是有人解答了吗

实际操作中存在问题

mhy2018

........................

mhy2018

顶一下吧，学习一下

任飘渺

看看对不对吧

Sub sdsds()
Dim dic As Object, arr, brr()
    Set dic = CreateObject("scripting.dictionary")
    With Sheet1
        arr = .[a1].CurrentRegion.Value
        ReDim brr(1 To UBound(arr), 1 To 3)
        For i = 2 To UBound(arr)
            If dic.exists(arr(i, 1)) = False Then Set dic(arr(i, 1)) = CreateObject("scripting.dictionary")
            If dic(arr(i, 1))(arr(i, 2)) = "" Then
                dic(arr(i, 1))(arr(i, 2)) = arr(i, 3)
            Else
                dic(arr(i, 1))(arr(i, 2)) = dic(arr(i, 1))(arr(i, 2)) & "/" & arr(i, 3)
            End If
        Next i
        
        k = dic.keys
        For i = 0 To UBound(k)
            brr(i + 1, 1) = k(i)
            items = dic(k(i)).items()
            For m = 0 To UBound(items)
                If m = 0 Then
                    brr(i + 1, 3) = items(m)
                Else
                     brr(i + 1, 3) = brr(i + 1, 3) & "/" & items(m)
                End If
            Next m
            m = dic(k(i)).keys
            For j = 0 To UBound(m)
                If brr(i + 1, 2) = "" Then
                    brr(i + 1, 2) = m(j)
                Else
                    brr(i + 1, 2) = brr(i + 1, 2) & "/" & m(j)
                End If
            Next j
        Next i
         .Range("e9").Resize(UBound(brr), 3) = brr
    End With
End Sub

hefuqing

1. Sub sds()
   
2. Dim brr()
   
3. arr = [a1].CurrentRegion
   
4. Set d = CreateObject("scripting.dictionary")
   
5. Set d1 = CreateObject("scripting.dictionary")
   
6. For i = 1 To UBound(arr)
   
7. d(arr(i, 1) & "/" & arr(i, 2)) = ""
   
8. Next
   
9. k = d.keys
   
10. 
    
11. For i = 0 To d.Count - 1
    
12. n = n + 1
    
13. ReDim Preserve brr(1 To 3, 1 To n)
    
14. brr(1, n) = Split(k(i), "/")(0)
    
15. brr(2, n) = Split(k(i), "/")(1)
    
16. Next
    
17. 
    
18. For i = 1 To UBound(brr, 2)
    
19. d1(brr(1, i)) = d1(brr(1, i)) & "/" & brr(2, i)
    
20. Next
    
21. k1 = d1.keys
    
22. t1 = d1.items
    
23. 
    
24. [F1].Resize(d1.Count, 1) = Application.Transpose(k1)
    
25. 
    
26. For i = 0 To d1.Count - 1
    
27. n1 = n1 + 1
    
28. Cells(n1, 7) = Mid(t1(i), 2)
    
29. Next
    
30. 
    
31. End Sub

复制代码

mhy2018

hefuqing 发表于 2018-8-21 17:19

不对 少了一列

mhy2018

任飘渺 发表于 2018-8-21 16:58
看看对不对吧

Sub sdsds()

能否注释一下

hefuqing

mhy2018 发表于 2018-8-21 17:26
不对 少了一列

给你加上 你等等