GBKEE

回復 1# Genie
試試看

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim D(1 To 2) As Object, AR(), Rng As Range, i As Integer, K As Variant
   
4.     Set D(1) = CreateObject("SCRIPTING.DICTIONARY")   '字典物件
   
5.     Set D(2) = CreateObject("SCRIPTING.DICTIONARY")
   
6.     Set Rng = Sheets("原始資料").Range("a2")          '儲存格物件
   
7.     Do
   
8.         '1. 依照 A 欄作區分，將資料由直向排列變為橫向排列。
   
9.         '2. 若依 A 欄作區分，就以 A 欄的值作為標題。
   
10.         If D(1).exists(Rng.Value) Then                      '字典物件.exists(Rng.Value) 關鍵字[存在] 條件成立
    
11.            AR = D(1)(Rng.Value)                             '陣列=字典物件(關鍵字)的內容
    
12.            ReDim Preserve AR(UBound(D(1)(Rng.Value)) + 1)   '陣列擴充增加一元素
    
13.            AR(UBound(AR)) = Rng.Cells(1, 3).Value           '陣列增加的元素=C欄的數值
    
14.            D(1)(Rng.Value) = AR                             '字典物件(關鍵字)的內容=陣列
    
15.         Else
    
16.             D(1)(Rng.Value) = Array(Rng.Cells(1, 3).Value)  '字典物件(關鍵字)的內容=陣列
    
17.         End If
    
18.         '*********************************************
    
19.         '1. 依照 B 欄作區分，將資料由直向排列變為橫向排列。
    
20.         '2. 若依 B 欄作區分，就以 A-B 欄的值作為標題
    
21.         K = "'" & Rng & " - " & Rng.Cells(1, 2)
    
22.         If D(2).exists(K) Then
    
23.            AR = D(2)(K)
    
24.            ReDim Preserve AR(UBound(D(2)(K)) + 1)
    
25.            AR(UBound(AR)) = Rng.Cells(1, 3).Value
    
26.            D(2)(K) = AR
    
27.         Else
    
28.             D(2)(K) = Array(Rng.Cells(, 3).Value)
    
29.         End If
    
30.         Set Rng = Rng.Offset(1)
    
31.     Loop Until Rng = ""
    
32.     With Sheets("sheet1")
    
33.         .Cells.Clear
    
34.         If D(1).Count > 0 Then
    
35.             i = 1
    
36.             For Each K In D(1).keys    'K= 字典物件(關鍵字)
    
37.                 .Cells(1, i) = K
    
38.                 .Cells(2, i).Resize(UBound(D(1)(K)) + 1) = Application.WorksheetFunction.Transpose(D(1)(K))  '讀取內容
    
39.                 i = i + 1
    
40.             Next
    
41.         End If
    
42.         If D(2).Count > 0 Then
    
43.             i = 10
    
44.             For Each K In D(2).keys
    
45.                 .Cells(1, i) = K
    
46.                 .Cells(2, i).Resize(UBound(D(2)(K)) + 1) = Application.WorksheetFunction.Transpose(D(2)(K))
    
47.                 i = i + 1
    
48.             Next
    
49.         End If
    
50.     End With
    
51. End Sub

複製代碼

GBKEE

回復 5# Genie

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim D As Object, AR(), Rng As Range, i As Integer, K As Variant, W As String
   
4.     Do
   
5.         W = InputBox("請選擇: A 欄作區分 或 B 欄作區分")
   
6.         If W = "" Then Exit Sub                         '沒輸入:離開程式
   
7.     Loop Until UCase(W) = "A" Or UCase(W) = "B"
   
8.     Set D = CreateObject("SCRIPTING.DICTIONARY")        '字典物件
   
9.     Set Rng = Sheets("原始資料").Range("a2")            '儲存格物件
   
10.     Do
    
11.         If UCase(W) = "A" Then K = Rng.Value
    
12.         If UCase(W) = "B" Then K = "'" & Rng & " - " & Rng.Cells(1, 2)
    
13.         If D.exists(K) Then                             '字典物件.exists(Rng.Value) 關鍵字[存在] 條件成立
    
14.             AR = D(K)                                   '陣列=字典物件(關鍵字)的內容
    
15.             ReDim Preserve AR(UBound(D(K)) + 1)         '陣列擴充增加一元素
    
16.             AR(UBound(AR)) = Rng.Cells(1, 3).Value      '陣列增加的元素=C欄的數值
    
17.             D(K) = AR                                   '字典物件(關鍵字)的內容=陣列
    
18.         Else
    
19.             D(K) = Array(Rng.Cells(1, 3).Value)         '字典物件(關鍵字)的內容=陣列
    
20.         End If
    
21.         Set Rng = Rng.Offset(1)
    
22.     Loop Until Rng = ""
    
23.     With Sheets("轉置後")
    
24.         .Cells.Clear
    
25.         If D.Count > 0 Then
    
26.             i = 1
    
27.             For Each K In D.keys    'K= 字典物件(關鍵字)
    
28.                 .Cells(1, i) = K
    
29.                 .Cells(2, i).Resize(UBound(D(K)) + 1) = Application.WorksheetFunction.Transpose(D(K))  '讀取內容
    
30.                 i = i + 1
    
31.             Next
    
32.         End If
    
33.     End With
    
34. End Sub

複製代碼