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

本帖最後由星空乂羽翼於 2023-7-5 15:27 編輯

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

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

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

0705_1.zip (10.07 KB)

樓主熱帖

Andy2483

　暱稱: 厚臉皮的學生

碩士班 Rank: 5 Rank: 5

帖子: 1516
主題: 40
精華: 0
積分: 1540
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 100
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2025-10-31

2^#

發表於 2023-7-6 09:31 | 只看該作者

本帖最後由 Andy2483 於 2023-7-6 09:50 編輯

回復 1# 星空乂羽翼

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

資料表:

結果表:

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.關鍵字是 "活動"

用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

Andy2483

　暱稱: 厚臉皮的學生

碩士班 Rank: 5 Rank: 5

帖子: 1516
主題: 40
精華: 0
積分: 1540
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 100
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2025-10-31

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

用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

星空乂羽翼