在一个Excel工作簿中拆分具有相同名称范围的图纸-Excel VBA

Question

我有一些Excel工作簿，其中包含100多张工作表。工作表名称如下所示；

• TTBMA2453_Speclist、TTBMA2454_Speclist和TTBMA2455_Speclist，然后继续
• WBXXTTBMA2453_Featurelist、WBXXTTBMA2454_Featurelist和WBXXTTBM A2455_Featurelist等等
• WBXXTTBMA2453_Corelist、WBXXTTBMA2454_Corelist和WBXXTTBMA2455_Corelist，然后继续

我想拆分同一工作簿中以相同规范名称开头的所有规范、功能和核心列表工作表，并使用Excel VBA合并/保存到特定文件中的另一个Excel工作簿。

(例如，将TTBMA2453_Speclist、WBXXTTBMA2452_Featurelist WBXXTTBMA2 453_Corellist合并为新工作簿和原始工作表(

请找到我的代码示例。此代码将相同名称的工作表(我手动添加(拆分为工作簿。但是，此代码不会重新合并其他工作簿中的工作表，并且工作表名称是手动输入的。所以，这不是我想要的。

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

Answer 1

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