求助一个分类的问题，谢谢各位老师

wds1061

求助各位老师，现在要收集店面的编号，不管有多少个，只要前面5个，原数据格式如A,B列，模拟结果见E列，因为数据太多了，各位老师能不能帮写个代码，先谢谢各位老师了！

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   With Worksheets("sheet1")
   
7.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.     arr = .Range("a2:b" & r)
   
9.     For i = 1 To UBound(arr)
   
10.       If Not d.exists(arr(i, 1)) Then
    
11.         Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
    
12.       End If
    
13.       If d(arr(i, 1)).Count < 5 Then
    
14.         d(arr(i, 1))(arr(i, 2)) = ""
    
15.       End If
    
16.       m = 1
    
17.       For Each aa In d.keys
    
18.         m = m + 1
    
19.         .Cells(m, 4) = aa
    
20.         .Cells(m, 5) = Join(d(aa).keys, ",")
    
21.       Next
    
22.     Next
    
23.   End With
    
24. End Sub
    

复制代码

chxw68

详见附件。

wds1061

chxw68 发表于 2019-3-14 15:23

感谢老师帮助，谢谢！

jiminyanyan

这样也行。
Sub test()
  Dim r%, i%
  Dim arr, brr
  Dim d As Object
  Set d = CreateObject("scripting.dictionary")
  With Worksheets("sheet1")
    r = .Cells(.Rows.Count, 1).End(xlUp).Row
    arr = .Range("a2:b" & r)
    For i = 1 To UBound(arr)
      If Not d.exists(arr(i, 1)) Then
        Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
      End If
      If d(arr(i, 1)).Count < 5 Then
        d(arr(i, 1))(arr(i, 2)) = ""
      End If
      Next
      m = 1
      For Each aa In d.keys
        m = m + 1
        .Cells(m, 4) = aa
        .Cells(m, 5) = Join(d(aa).keys, ",")
      Next
  End With
End Sub