[發問] 依資料標題 分割多個工作頁

星空乂羽翼

附件的動作執行如下說明
依附件裡工作表1 的資料分割出
一月、二月、三月、四月的工作頁 (建立新工作頁並依標題命名工作頁)
並將相關的資料複製到該月的工作頁裡。

工作表1 的資料裡有重複月份 (二月)
若遇重複月份的時候
將重複的月份的活動貼到該月份工作頁內 (成效如附件的二月)

請問各位前輩上述動作如何撰寫成通用的VBA程式呢?

0705_1.zip (10.07 KB)

下載次數: 9

2023-7-5 15:16

Andy2483

回復 1# 星空乂羽翼


    謝謝論壇,謝謝前輩發表此主題與範例
後學藉此帖練習陣列與字典,學習方案如下

資料表:

下載 (74.88 KB)

2023-7-6 09:26

結果表:

下載 (10.41 KB)

2023-7-6 09:26

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

學習重點:
1.以字典記錄工作表名是否存在
2.以字典記錄每個工作表使用的最後列數
3.關鍵字是 "活動"

Andy2483

謝謝論壇,謝謝各位前輩
後學藉此帖練習陣列與字典,學習方案如下


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.一次性寫入工作表中

星空乂羽翼

回復 3# Andy2483
感謝前輩的教學
後學先來學習學習
若有問題再跟前輩請教請教
謝謝！