- 帖子
- 1446
- 主題
- 40
- 精華
- 0
- 積分
- 1470
- 點名
- 0
- 作業系統
- Windows 7
- 軟體版本
- Excel 2010 & 2016
- 閱讀權限
- 50
- 性別
- 男
- 來自
- 台灣
- 註冊時間
- 2020-7-15
- 最後登錄
- 2024-10-21
|
3#
發表於 2023-7-6 11:58
| 只看該作者
謝謝論壇,謝謝各位前輩
後學藉此帖練習陣列與字典,學習方案如下
Option Explicit
Sub TEST_1()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim Brr, Crr(1 To 1000, 1 To 1), A, Z, Q, i&, R&, T$
Set Z = CreateObject("Scripting.Dictionary")
For Each Q In Worksheets
If Q.Name <> "工作表1" Then Q.Delete
Next
Brr = Range([工作表1!A1], [工作表1!A65536].End(xlUp)(2))
For i = 1 To UBound(Brr) - 1
If Brr(i + 1, 1) <> "活動" Then GoTo i01
T = Application.Text(Brr(i, 1), "[DBNum1]m月")
A = Z(T): R = Z(T & "/r")
If Not IsArray(A) Then
A = Crr
A(1, 1) = T
A(2, 1) = Brr(i + 1, 1)
A(3, 1) = Brr(i + 2, 1)
Z(T) = 1: Z(T & "/r") = 3: i = i + 2: Z(T) = A: GoTo i01
End If
R = R + 1
A(R, 1) = Brr(i + 2, 1)
Z(T & "/r") = R: Z(T) = A
i01: Next
For Each Q In Z.KEYS
If Not IsArray(Z(Q)) Then GoTo z01
With Worksheets.Add(after:=Worksheets(Sheets.Count))
.Name = Q
.[A1].Resize(Z(Q & "/r"), 1) = Z(Q)
End With
z01: Next
Application.Goto [工作表1!A1]
Set Z = Nothing: Erase Brr, A, Crr
End Sub
學習重點:
1.字典 ITEM是二維陣列
2.一次性寫入工作表中 |
|
