dechiuan999

你好：

  請試試如下：

1. Sub bb()
   
2.    
   
3.     Dim mSht As Worksheet
   
4.     Dim mRng As Range, E As Range
   
5.     Dim ar, mSplit
   
6.     Dim mDic As Object
   
7.     Dim s%, s1%, s2%
   
8.    
   
9.    
   
10.     Set mDic = CreateObject("scripting.dictionary")
    
11.     Set mSht = Worksheets(1)
    
12.     With mSht
    
13.         Set mRng = .Range("a1", .Range("a" & .Rows.Count).End(xlUp))
    
14.         
    
15.         For Each E In mRng
    
16.            
    
17.             If Not mDic.Exists(E.Value) Then
    
18.                 mDic(E.Value) = E.Offset(, 1).Value
    
19.             Else
    
20.                
    
21.                 mDic(E.Value) = mDic(E.Value) & "," & E.Offset(, 1)
    
22.                
    
23.             End If
    
24.          
    
25.         Next
    
26.       
    
27.         s = 1
    
28.         s1 = 10
    
29.         For Each ar In mDic.Keys
    
30.             .Cells(s, s1) = ar
    
31.             mSplit = Split(mDic(ar), ",")
    
32.             For s2 = 0 To UBound(mSplit)
    
33.                 .Cells(s, s1 + 1) = mSplit(s2)
    
34.                 .Cells(1, s1 + 1) = "部門名稱"
    
35.                 s1 = s1 + 1
    
36.             Next
    
37.             s = s + 1
    
38.             s1 = 10
    
39.         Next
    
40.         
    
41.     End With
    
42.    
    
43. End Sub

複製代碼