[已解决]VBA代码求助

twtthduu

请老师看一下,如何写这个VBA代码 VBA代码求助.rar (14.27 KB, 下载次数: 25)

2012-1-15 00:21 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

sunjing-zxl

2012-1-15 08:51

1. Sub aa()
   
2.     Dim arr
   
3.     Dim arr2
   
4.     Dim d As New Dictionary
   
5.     Dim i As Long
   
6.     arr = Range("a2:b" & Range("b65536").End(xlUp).Row)
   
7.     For i = 1 To UBound(arr, 1)
   
8.         If Not d.Exists(arr(i, 1)) = True Then
   
9.             Set d(arr(i, 1)) = New Dictionary
   
10.             d(arr(i, 1))(arr(i, 2)) = ""
    
11.         Else
    
12.             d(arr(i, 1))(arr(i, 2)) = ""
    
13.         End If
    
14.     Next i
    
15.     ReDim arr2(0 To d.Count - 1, 1 To 2)
    
16.     For i = 0 To d.Count - 1
    
17.         arr2(i, 1) = d.Keys(i)
    
18.         'arr2(i, 2) = Join(d.Items(i).Keys, ",")
    
19.         arr2(i, 2) = d.Items(i).Keys
    
20.     Next i
    
21.     'Range("k2").Resize(d.Count, 2) = arr2
    
22.     Range("D19").Resize(UBound(arr2) + 1, 1) = arr2
    
23.     For i = 1 To UBound(arr2) + 1
    
24.         Cells(18 + i, 5).Resize(1, UBound(arr2(i - 1, 2)) + 1) = arr2(i - 1, 2)
    
25.     Next i
    
26. End Sub

复制代码

跳转到最佳答案楼层

sunjing-zxl

1. Sub aa()
   
2.     Dim arr
   
3.     Dim arr2
   
4.     Dim d As New Dictionary
   
5.     Dim i As Long
   
6.     arr = Range("a2:b" & Range("b65536").End(xlUp).Row)
   
7.     For i = 1 To UBound(arr, 1)
   
8.         If Not d.Exists(arr(i, 1)) = True Then
   
9.             Set d(arr(i, 1)) = New Dictionary
   
10.             d(arr(i, 1))(arr(i, 2)) = ""
    
11.         Else
    
12.             d(arr(i, 1))(arr(i, 2)) = ""
    
13.         End If
    
14.     Next i
    
15.     ReDim arr2(0 To d.Count - 1, 1 To 2)
    
16.     For i = 0 To d.Count - 1
    
17.         arr2(i, 1) = d.Keys(i)
    
18.         'arr2(i, 2) = Join(d.Items(i).Keys, ",")
    
19.         arr2(i, 2) = d.Items(i).Keys
    
20.     Next i
    
21.     'Range("k2").Resize(d.Count, 2) = arr2
    
22.     Range("D19").Resize(UBound(arr2) + 1, 1) = arr2
    
23.     For i = 1 To UBound(arr2) + 1
    
24.         Cells(18 + i, 5).Resize(1, UBound(arr2(i - 1, 2)) + 1) = arr2(i - 1, 2)
    
25.     Next i
    
26. End Sub

复制代码

twtthduu

sunjing-zxl 发表于 2012-1-15 08:51

谢谢,真是高手呀.辛苦了.达到要求

libenwen2011

高手