我有一些 Excel 作業簿，其中包含 100 多張紙。作業表名稱如下；
- TTBMA2453 _Speclist、TTBMA2454_Speclist、TTBMA2455_Speclist 和繼續..
- WBXX TTBMA2453 _Featurelist、WBXXTTBMA2454_Featurelist、WBXXTTBMA2455_Featurelist 和繼續..
- WBXX TTBMA2453 _Corelist、WBXXTTBMA2454_Corelist、WBXXTTBMA2455_Corelist 并繼續..
我想拆分在同一作業簿中以相同規格串列名稱開頭的所有規范、功能和核心串列表，并使用 Excel VBA 合并/保存到特定檔案中的另一個 Excel 作業簿。
（例如結合 TTBMA2453_Speclist、WBXX TTBMA2453 _Featurelist WBXX TTBMA2453 _Corelist 并將它們復制為帶有原始作業表的新作業簿）
請找到我擁有的代碼示例。此代碼將同名的作業表（我手動添加的）拆分為作業簿。但是，此代碼不會重新合并不同作業簿中的作業表，并且作業表名稱是手動輸入的。所以，這不是我想要的。
Sub SplitEachWorksheet()
Dim FPath As String
FPath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim ws As Worksheet
Dim fnameList, fnameCurFile As Variant
Dim countFiles, countSheets As Integer
Dim wksCurSheet As Worksheet
Dim wbkCurBook, wbkSrcBook As Workbook
For Each ws In ThisWorkbook.Worksheets
If Left$(ws.Name, 9) = "TTBMA2453" Then ' <--- added an IF statement
ws.Copy
Application.ActiveWorkbook.SaveAs Filename:=FPath & "\" & ws.Name & ".xlsx"
Application.ActiveWorkbook.Close False
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
uj5u.com熱心網友回復：
Option Explicit
Sub SplitEachWorksheet()
Dim wb As Workbook, wbNew As Workbook, ws As Worksheet
Dim num As Collection, n, dict As Object
Dim FPath As String
FPath = Application.ActiveWorkbook.Path
Set num = new Collection
Set dict = CreateObject("Scripting.Dictionary")
Set wb = ThisWorkbook
For Each ws In wb.Worksheets
If ws.Name Like "*_Speclist" Then
num.Add Left(ws.Name, Len(ws.Name) - 9)
End If
dict.Add ws.Name, ws.Index
Next
' check sheets
Dim msg As String, s As String
For Each n In num
s = "WBXX" & n & "_Corelist"
If Not dict.exists(s) Then
msg = msg & vbLf & s & " missing"
End If
s = "WBXX" & n & "_Featurelist"
If Not dict.exists(s) Then
msg = msg & vbLf & s & " missing"
End If
Next
If Len(msg) > 0 Then
MsgBox msg, vbCritical
Exit Sub
End If
' check workbooks
Application.ScreenUpdating = False
For Each n In num
wb.Sheets(n & "_Speclist").Copy
Set wbNew = ActiveWorkbook
wb.Sheets("WBXX" & n & "_Featurelist").Copy after:=wbNew.Sheets(1)
wb.Sheets("WBXX" & n & "_Corelist").Copy after:=wbNew.Sheets(2)
wbNew.SaveAs Filename:=FPath & "\" & n
wbNew.Close False
Next
Application.ScreenUpdating = True
' result
MsgBox num.Count & " worksbooks created in " & FPath, vbInformation
End Sub
轉載請註明出處，本文鏈接：https://www.uj5u.com/shujuku/361270.html
下一篇：While回圈使Excel崩潰