- 帖子
- 1425
- 主題
- 40
- 精華
- 0
- 積分
- 1449
- 點名
- 0
- 作業系統
- Windows 7
- 軟體版本
- Excel 2010 & 2016
- 閱讀權限
- 50
- 性別
- 男
- 來自
- 台灣
- 註冊時間
- 2020-7-15
- 最後登錄
- 2024-4-16
|
謝謝論壇,謝謝各位前輩
後學藉此帖練習陣列與字典,學習方案如下,請前輩們指教
執行前:
輸入窗輸入"A":
輸入窗輸入"B":
Option Explicit
Sub TEST()
Dim Brr, Crr(1 To 1000, 1 To 1), A, Y, strNo1, R&, C%, i&, T1$, T2$, T3$, TT$
Dim xR As Range, Sh1 As Worksheet, Sh2 As Worksheet
strNo1 = InputBox("輸入欄位A或B", , "A")
If StrPtr(strNo1) = 0 Or InStr("/A/B/", "/" & strNo1 & "/") = 0 Then Exit Sub
Set Y = CreateObject("Scripting.Dictionary")
Set Sh1 = Sheets("原始資料"): Set xR = Sh1.[A1].CurrentRegion: Brr = xR
Set Sh2 = Sheets("轉置後"): Sh2.UsedRange.Clear
For i = 2 To UBound(Brr)
T1 = Brr(i, 1): T2 = Brr(i, 2): T3 = Brr(i, 3)
TT = Switch(strNo1 = "A", T1, strNo1 = "B", T1 & "-" & T2)
A = Y(TT)
If Not IsArray(A) Then A = Crr: C = C + 1: Y(TT & "|c") = C
R = Y(TT & "|r"): R = R + 1: Y(TT & "|r") = R
A(R, 1) = T3
Y(TT) = A
Next
For Each A In Y.keys
If IsArray(Y(A)) Then
Sh2.Cells(1, Y(A & "|c")) = "'" & A
Sh2.Cells(2, Y(A & "|c")).Resize(Y(A & "|r"), 1) = Y(A)
End If
Next
Set Y = Nothing: Set xR = Nothing: Erase Brr, Crr
Set Sh1 = Nothing: Set Sh2 = Nothing
End Sub |
|
發表於 2023-4-13 16:15
| 