如何在VBA拆分生成的子文件中复制源文件指定工作表？

原代码仅复制了Sheet1到新工作簿，未包含指定的"Program"、"Banked"、"Drive"三个工作表。修改思路是先创建空白工作簿，再将所有需要的工作表批量复制过去，同时保留原有的数据拆分逻辑。

修改后的完整代码：

Option Explicit
Sub Demo()
    Dim i As Long, j As Long, sPath As String, lastRow As Range
    Dim rowCnt As Long, ColCnt As Long, rngData As Range
    Dim arrData, arrRes(0, 1 To 256) ' 预设足够列数，可根据实际数据调整
    Dim oSht As Worksheet, oWK As Workbook
    Dim sheetNames() As String, k As Integer
    Const START_ROW = 8
    Const MTH_DIR = "202406"
    Const SHEETS_TO_COPY = "Sheet1,Program,Banked,Drive" ' 指定需要复制的所有工作表
    
    ' 拆分工作表名称为数组
    sheetNames = Split(SHEETS_TO_COPY, ",")
    
    sPath = ThisWorkbook.Path & "\" & MTH_DIR
    If Len(Dir(sPath, vbDirectory)) = 0 Then MkDir sPath
    If Right(sPath, 1) <> "\" Then sPath = sPath & "\" 
    
    Set oSht = ThisWorkbook.Sheets("Sheet1")
    Set rngData = oSht.Range("A1").CurrentRegion
    rowCnt = rngData.Rows.Count
    ColCnt = rngData.Columns.Count
    arrData = rngData.Value
    
    ' 创建新工作簿并复制指定工作表
    Set oWK = Workbooks.Add(xlWBATWorksheet) ' 新建仅含1个空白表的工作簿
    For k = LBound(sheetNames) To UBound(sheetNames)
        ThisWorkbook.Sheets(sheetNames(k)).Copy After:=oWK.Sheets(oWK.Sheets.Count)
    Next k
    ' 删除新建工作簿自带的空白表
    Application.DisplayAlerts = False
    oWK.Sheets(1).Delete
    Application.DisplayAlerts = True
    
    ' 保留原逻辑处理Sheet1的表头和格式
    With oWK.Sheets("Sheet1")
        Set lastRow = .Cells(START_ROW, 1).Resize(, ColCnt)
        .Rows(START_ROW + 1 & ":" & .Rows.Count).Delete
        With lastRow.Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Weight = xlThick
        End With
    End With
    
    ' 循环生成每个成员的子文件
    For i = START_ROW To rowCnt
        If Len(arrData(i, 1)) > 0 Then
            If i > START_ROW Then
                For j = 1 To ColCnt
                    arrRes(0, j) = arrData(i, j)
                Next
                lastRow.Value = arrRes
            End If
            oWK.SaveAs sPath & arrData(i, 1) & ".xlsx"
        End If
    Next
    oWK.Close False
End Sub

关键修改说明：

• 新增SHEETS_TO_COPY常量，集中定义需要复制的所有工作表名称，便于后续调整
• 替换原oSht.Copy逻辑：先创建空白工作簿，再逐个复制指定工作表，最后删除默认空白表
• 保留原有的数据拆分、格式设置和文件保存逻辑，确保核心功能不受影响

内容的提问来源于stack exchange，提问作者Austin Bertrand