数据处理

LS115115

请大神帮忙：
共用物料合并到一个单元格，因为数据很多，用函数处理起来很慢，需要用到VBA

具体如附件，谢谢

shiruiqiang

shiruiqiang

Sub test()
Dim arr, brr
Dim dic
Set dic = CreateObject("scripting.dictionary")
arr = Sheets(1).[a1].CurrentRegion
ReDim brr(1 To UBound(arr), 1 To 2)
For x = 1 To UBound(arr)
If Not dic.exists(arr(x, 1)) Then
dic(arr(x, 1)) = dic.Count + 1
brr(dic(arr(x, 1)), 1) = arr(x, 1)
brr(dic(arr(x, 1)), 2) = arr(x, 2)
Else
brr(dic(arr(x, 1)), 2) = brr(dic(arr(x, 1)), 2) & "," & arr(x, 2)
End If
Next

Sheets(1).[d1].Resize(dic.Count, 2) = brr

End Sub

Qs18

1. Sub qs()
   
2. Dim arr, i, d As Object
   
3. Set dic = CreateObject("scripting.dictionary")
   
4. arr = Sheet1.Range("a1").CurrentRegion.Value
   
5. ReDim brr(1 To UBound(arr), 1 To 2)
   
6. For i = 1 To UBound(arr)
   
7.     s = arr(i, 1)
   
8.     If Not dic.exists(s) Then
   
9.         m = m + 1
   
10.         dic(s) = m
    
11.         brr(m, 1) = s: brr(m, 2) = arr(i, 2)
    
12.     Else
    
13.         r = dic(s)
    
14.         brr(r, 2) = brr(r, 2) & "," & arr(i, 2)
    
15.     End If
    
16. Next
    
17. Sheet1.Range("f16").Resize(m, 2) = brr
    
18. End Sub
    

复制代码

Qs18

试试..........

Qs18

试试............

gwjkkkkk

Option Explicit
Sub TEST6()
    Dim ar, i&, dic As Object
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
   
    ar = [A1].CurrentRegion.Value
    For i = 1 To UBound(ar)
        dic(ar(i, 1)) = dic(ar(i, 1)) & "," & ar(i, 2)
    Next i
   
    ReDim ar(dic.Count - 1, 1)
    For i = 0 To dic.Count - 1
        ar(i, 0) = dic.keys()(i)
        ar(i, 1) = Mid(dic.items()(i), 2)
    Next i
   
    [F16].Resize(UBound(ar) + 1, 2) = ar
    Set dic = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

,,,,,,,,,,,,,,

LS115115

Qs18 发表于 2024-9-7 20:01
试试............

谢谢，兄弟，大周末的还劳烦您，非常感谢

LS115115

谢谢以上兄弟帮忙，大周末的还麻烦大家，真心的谢谢