Option Explicit
Sub TEST()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim Brr, 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月") http://forum.twbts.com/viewthrea ... mp;page=3#pid120120
'學到了 就拿來運用,謝謝 准提部林前輩
R = Z(T & "/r")
If Z(T) = "" Then
With Worksheets.Add(after:=Worksheets(Sheets.Count))
.Name = T
.Cells(1, 1) = T
.Cells(2, 1) = Brr(i + 1, 1)
.Cells(3, 1) = Brr(i + 2, 1)
End With
Z(T) = 1: Z(T & "/r") = 3: i = i + 2: GoTo i01
End If
R = R + 1
Sheets(T).Cells(R, 1) = Brr(i + 2, 1)
Z(T & "/r") = R
i01: Next
Application.Goto [工作表1!A1]
Set Z = Nothing: Erase Brr
End Sub
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
