- 帖子
- 5923
- 主題
- 13
- 精華
- 1
- 積分
- 5986
- 點名
- 0
- 作業系統
- win10
- 軟體版本
- Office 2010
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台灣基隆
- 註冊時間
- 2010-5-1
- 最後登錄
- 2022-1-23
        
|
本帖最後由 GBKEE 於 2013-1-7 18:38 編輯
回復 1# Genie
試試看- Option Explicit
- Sub Ex()
- Dim D(1 To 2) As Object, AR(), Rng As Range, i As Integer, K As Variant
- Set D(1) = CreateObject("SCRIPTING.DICTIONARY") '字典物件
- Set D(2) = CreateObject("SCRIPTING.DICTIONARY")
- Set Rng = Sheets("原始資料").Range("a2") '儲存格物件
- Do
- '1. 依照 A 欄作區分，將資料由直向排列變為橫向排列。
- '2. 若依 A 欄作區分，就以 A 欄的值作為標題。
- If D(1).exists(Rng.Value) Then '字典物件.exists(Rng.Value) 關鍵字[存在] 條件成立
- AR = D(1)(Rng.Value) '陣列=字典物件(關鍵字)的內容
- ReDim Preserve AR(UBound(D(1)(Rng.Value)) + 1) '陣列擴充增加一元素
- AR(UBound(AR)) = Rng.Cells(1, 3).Value '陣列增加的元素=C欄的數值
- D(1)(Rng.Value) = AR '字典物件(關鍵字)的內容=陣列
- Else
- D(1)(Rng.Value) = Array(Rng.Cells(1, 3).Value) '字典物件(關鍵字)的內容=陣列
- End If
- '*********************************************
- '1. 依照 B 欄作區分，將資料由直向排列變為橫向排列。
- '2. 若依 B 欄作區分，就以 A-B 欄的值作為標題
- K = "'" & Rng & " - " & Rng.Cells(1, 2)
- If D(2).exists(K) Then
- AR = D(2)(K)
- ReDim Preserve AR(UBound(D(2)(K)) + 1)
- AR(UBound(AR)) = Rng.Cells(1, 3).Value
- D(2)(K) = AR
- Else
- D(2)(K) = Array(Rng.Cells(, 3).Value)
- End If
- Set Rng = Rng.Offset(1)
- Loop Until Rng = ""
- With Sheets("sheet1")
- .Cells.Clear
- If D(1).Count > 0 Then
- i = 1
- For Each K In D(1).keys 'K= 字典物件(關鍵字)
- .Cells(1, i) = K
- .Cells(2, i).Resize(UBound(D(1)(K)) + 1) = Application.WorksheetFunction.Transpose(D(1)(K)) '讀取內容
- i = i + 1
- Next
- End If
- If D(2).Count > 0 Then
- i = 10
- For Each K In D(2).keys
- .Cells(1, i) = K
- .Cells(2, i).Resize(UBound(D(2)(K)) + 1) = Application.WorksheetFunction.Transpose(D(2)(K))
- i = i + 1
- Next
- End If
- End With
- End Sub
|
|
發表於 2013-1-7 17:46
| 
