不用字典，用一个简单的vba能实现不？各位大神仙看看

卡度

谢谢，拜托了

№①布鲑鲑

不用字典用VBA？意思是VBA里不用字典方法，这要求好奇怪

蓝桥玄霜

这种问题用字典是最方便的了。

1. Sub lqxs()
   
2. Dim Arr, i&
   
3. Dim d, k, t
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. Sheet1.Activate
   
6. Arr = [a1].CurrentRegion
   
7. For i = 1 To UBound(Arr)
   
8.     If Not d.exists(Arr(i, 1)) Then
   
9.         d(Arr(i, 1)) = Arr(i, 2)
   
10.     Else
    
11.         d(Arr(i, 1)) = d(Arr(i, 1)) & "，" & Arr(i, 2)
    
12.     End If
    
13. Next
    
14. k = d.keys: t = d.items
    
15. [d1].Resize(d.Count) = Application.Transpose(k)
    
16. [e1].Resize(d.Count) = Application.Transpose(t)
    
17. End Sub
    

复制代码

笑着...两年过去

那就用个简单的数组

1. Sub test()
   
2.     ReDim arr(1 To [a1].End(4).Row, 1 To 2)
   
3.     For i = 1 To [a1].End(4).Row
   
4.         If Application.CountIf(Range("a1:a" & i), Cells(i, 1)) = 1 Then
   
5.            j = j + 1
   
6.            arr(j, 1) = Cells(i, 1)
   
7.            arr(j, 2) = Cells(i, 2)
   
8.         Else
   
9.            arr(j, 2) = arr(j, 2) & "," & Cells(i, 2)
   
10.         End If
    
11.     Next
    
12.     [d1].Resize(j, 2) = arr
    
13. End Sub
    

复制代码

qy1219no2

不使用字典的代码（没学会字典前，我也经常对字典犯怵，只好用下面的办法解决，不过，如果数据量多的话，还是建议用字典，这样运算速度会提高不少）

1. Sub objDic()
   
2.     Dim sj(), nRow%, i%, k%, cBj$, r As Range, cAdd$
   
3.     nRow = [a65536].End(xlUp).Row
   
4.     If nRow < 2 Then Exit Sub
   
5.     arr = [a2].Resize(nRow - 1, 2)
   
6.     ReDim sj(nRow - 2, 1): k = -1
   
7.     For i = 1 To nRow - 1
   
8.         If InStr(cBj, arr(i, 1)) = 0 Then
   
9.             cBj = cBj & arr(i, 1) & ","
   
10.             k = k + 1
    
11.             sj(k, 0) = arr(i, 1)
    
12.             Set r = [a:a].Find(arr(i, 1), , , 1)
    
13.             If Not r Is Nothing Then
    
14.                 cAdd = r.Address
    
15.                 Do
    
16.                     sj(k, 1) = sj(k, 1) & r.Offset(, 1) & ","
    
17.                     Set r = [a:a].FindNext(r)
    
18.                 Loop While Not r Is Nothing And r.Address <> cAdd
    
19.                 If sj(k, 1) <> "" Then sj(k, 1) = Left(sj(k, 1), Len(sj(k, 1)) - 1)
    
20.             End If
    
21.         End If
    
22.     Next
    
23.     [d2].Resize(nRow - 1, 2) = sj
    
24. End Sub
    

复制代码

yaozong

为啥不欢喜用字典呢！

如果班级有序排列（同班归在一起）时

Sub yy()
Dim arr, s$, i, m
arr = [a1].CurrentRegion
For i = 1 To UBound(arr)
   If InStr(s, arr(i, 1)) = 0 Then
      m = m + 1
      arr(m, 1) = arr(i, 1)
      arr(m, 2) = arr(i, 2)
      s = s & arr(i, 1)
   Else
      arr(m, 2) = arr(m, 2) & "," & arr(i, 2)
   End If
Next
[d1].Resize(m, 2) = arr
End Sub

yaozong

如果班级乱序排列时

Sub zz()
Application.ScreenUpdating = False
Dim arr, brr, s$, i, m
brr = [a1].CurrentRegion
[a1].CurrentRegion.Sort key1:=[a1], order1:=1, header:=xlYes
arr = [a1].CurrentRegion
For i = 1 To UBound(arr)
   If InStr(s, arr(i, 1)) = 0 Then
      m = m + 1
      arr(m, 1) = arr(i, 1)
      arr(m, 2) = arr(i, 2)
      s = s & arr(i, 1)
   Else
      arr(m, 2) = arr(m, 2) & "," & arr(i, 2)
   End If
Next
[a1].Resize(UBound(brr), UBound(brr, 2)) = brr
[d1].Resize(m, 2) = arr
Application.ScreenUpdating = True
End Sub

卡度

蓝桥玄霜 发表于 2015-3-10 11:32
这种问题用字典是最方便的了。

用了大神的代码，出错了，显示类型不对，也不知道该改哪里，实际数据如图

jpj123

有简单的字典法，为什么不用呢？

张三李四

1. Sub test()
   
2. '不用词典不用数组的代码来了。
   
3. Application.ScreenUpdating = False
   
4. Range("D:F").ClearContents
   
5. mylastrow = Range("A65536").End(xlUp).Row
   
6. For h = 1 To mylastrow
   
7.    班级 = Cells(h, 1)
   
8.    myrow = Application.Match(班级, Range("D:D"), 0)
   
9.   If IsNumeric(myrow) = False Then
   
10.       myrow = Range("D65536").End(xlUp).Row
    
11.       If myrow = 1 And Cells(1, 4) = Empty Then
    
12.          Cells(1, 4) = 班级
    
13.          Cells(1, 5) = Cells(h, 2)
    
14.       Else
    
15.          myrow = myrow + 1
    
16.          Cells(myrow, 4) = 班级
    
17.          Cells(myrow, 5) = Cells(h, 2)
    
18.       
    
19.       End If
    
20.   Else
    
21.          Cells(myrow, 5) = Cells(myrow, 5) & "，" & Cells(h, 2)
    
22.   End If
    
23. Next h
    
24. Application.ScreenUpdating = False
    
25. End Sub
    

复制代码