- 帖子
- 2035
- 主題
- 24
- 精華
- 0
- 積分
- 2031
- 點名
- 0
- 作業系統
- Win7
- 軟體版本
- Office2010
- 閱讀權限
- 100
- 性別
- 男
- 註冊時間
- 2012-3-22
- 最後登錄
- 2024-2-1
|
本帖最後由 c_c_lai 於 2013-1-8 07:27 編輯
回復 6# GBKEE
回復 5# Genie
GBKEE 版大早安！
今早讀了 "資料直向轉橫向排列" 發覺 Idea 不錯，於是乎
除了原先的 "A欄、B 欄" ，我又加入了 "AB 欄" 選項。
來取樂一下，請勿見怪！(我另增加一工作表單 "測試結果")- Sub Ex2()
- Dim D As Object, AR(), Rng As Range, i As Integer, K As Variant, W As String
- Dim cts As Integer, nums As Integer
-
- ' Do
- ' W = InputBox("請選擇: A 欄作區分 或 B 欄作區分")
- ' If W = "" Then Exit Sub ' 沒輸入:離開程式
- ' Loop Until UCase(W) = "A" Or UCase(W) = "B"
- W = InputBox("請選擇: A 欄作區分 或 B 欄作區分、" & vbCrLf & "亦或是 AB 欄作區分")
- If UCase(W) <> "A" And UCase(W) <> "B" And UCase(W) <> "AB" Then Exit Sub ' 沒輸入:離開程式
-
- nums = IIf(UCase(W) = "AB", 2, 1)
- Set D = CreateObject("Scripting.Dictionary") ' 字典物件
-
- For cts = 1 To nums
- Set Rng = Sheets("原始資料").Range("a2") ' 儲存格物件
-
- Do
- If UCase(W) = "AB" Then
- K = IIf(cts = 1, Rng.Value, "'" & Rng & " - " & Rng.Cells(1, 2))
- Else
- K = IIf(UCase(W) = "A", Rng.Value, "'" & Rng & " - " & Rng.Cells(1, 2))
- End If
-
- If D.exists(K) Then ' 字典物件.exists(Rng.Value) 關鍵字[存在] 條件成立
- AR = D(K) ' 陣列=字典物件(關鍵字)的內容
- ReDim Preserve AR(UBound(D(K)) + 1) ' 陣列擴充增加一元素
- AR(UBound(AR)) = Rng.Cells(1, 3).Value ' 陣列增加的元素=C欄的數值
- D(K) = AR ' 字典物件(關鍵字)的內容=陣列
- Else
- D(K) = Array(Rng.Cells(1, 3).Value) ' 字典物件(關鍵字)的內容=陣列
- End If
- Set Rng = Rng.Offset(1)
- Loop Until Rng = ""
- Next
-
- With Sheets("測試結果")
- .Cells.Clear
-
- If D.Count > 0 Then
- i = 1
- For Each K In D.keys ' K = 字典物件(關鍵字)
- .Cells(1, i) = K
- .Cells(2, i).Resize(UBound(D(K)) + 1) = Application.WorksheetFunction.Transpose(D(K)) ' 讀取內容
- i = i + 1
- Next
- End If
- End With
- End Sub
|
|
發表於 2013-1-8 07:26
| 
