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

Question

我有一些 Excel 工作簿，其中包含 100 多个 sheet。 sheet 名称如下；

TTBMA2453_Speclist，TTBMA2454_Speclist，TTBMA2455_Speclist 继续..
WBXXTTBMA2453_Featurelist，WBXXTTBMA2454_Featurelist，WBXXTTBMA2455_Featurelist 继续..
WBXXTTBMA2453_Corelist，WBXXTTBMA2454_Corelist，WBXXTTBMA2455_Corelist 继续..

我想将同一工作簿中以相同规范列表名称开头的所有规范、功能和核心列表 sheet 和 merge/save 拆分到特定文件中的另一个 Excel 工作簿使用 Excel VBA.

（例如合并 TTBMA2453_Speclist、WBXXTTBMA2453_Featurelist WBXXTTBMA2453_Corelist 并将它们复制为带有原始 sheets)

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

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

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

Splitting Sheets with Same Name Range in One Excel Workbook - Excel VBA

excel

merge

vba

split

copy