Excel宏/VBA修改：如何让宏选取指定工作表？

方案1：提取每个文件的最后一个工作表 #

直接修改原代码中指定工作表索引的部分，把Sheets(1)替换为Sheets(wbkSrcBook.Sheets.Count)——wbkSrcBook.Sheets.Count会返回目标文件的总工作表数量，对应最后一个工作表的索引。

完整代码：

Sub MASTER_MergeExcelFiles_LastSheet()
    Dim fnameList, fnameCurFile As Variant
    Dim countFiles, countSheets As Integer
    Dim wbkCurBook, wbkSrcBook As Workbook
 
    fnameList = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="Choose Excel files to merge", MultiSelect:=True)
 
    If (vbBoolean <> VarType(fnameList)) Then
        If (UBound(fnameList) > 0) Then
            countFiles = 0
            countSheets = 0
 
            Application.ScreenUpdating = False
            Application.Calculation = xlCalculationManual
 
            Set wbkCurBook = ActiveWorkbook
 
            For Each fnameCurFile In fnameList
                countFiles = countFiles + 1
                Set wbkSrcBook = Workbooks.Open(Filename:=fnameCurFile)
                
                ' 提取最后一个工作表
                countSheets = countSheets + 1
                wbkSrcBook.Sheets(wbkSrcBook.Sheets.Count).Copy after:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
                
                wbkSrcBook.Close SaveChanges:=False
            Next
 
            Application.ScreenUpdating = True
            Application.Calculation = xlCalculationAutomatic
 
            MsgBox "Processed " & countFiles & " files" & vbCrLf & "Merged " & countSheets & " worksheets", Title:="Merge Excel files"
        End If
    Else
        MsgBox "No files selected", Title:="Merge Excel files"
    End If
End Sub

方案2：提取指定名称为“Data Tab”的工作表 #

如果要提取固定名称的工作表，直接用工作表名称定位即可，建议添加错误处理——如果目标文件中不存在“Data Tab”工作表，程序会跳过该文件并给出提示，避免报错中断。

完整代码：

Sub MASTER_MergeExcelFiles_SpecifiedSheet()
    Dim fnameList, fnameCurFile As Variant
    Dim countFiles, countSheets As Integer
    Dim wbkCurBook, wbkSrcBook As Workbook
    Dim targetSheet As Worksheet
 
    fnameList = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="Choose Excel files to merge", MultiSelect:=True)
 
    If (vbBoolean <> VarType(fnameList)) Then
        If (UBound(fnameList) > 0) Then
            countFiles = 0
            countSheets = 0
 
            Application.ScreenUpdating = False
            Application.Calculation = xlCalculationManual
 
            Set wbkCurBook = ActiveWorkbook
 
            For Each fnameCurFile In fnameList
                countFiles = countFiles + 1
                Set wbkSrcBook = Workbooks.Open(Filename:=fnameCurFile)
                
                ' 尝试定位指定名称的工作表
                On Error Resume Next
                Set targetSheet = wbkSrcBook.Sheets("Data Tab")
                On Error GoTo 0
                
                If Not targetSheet Is Nothing Then
                    ' 找到工作表则复制
                    countSheets = countSheets + 1
                    targetSheet.Copy after:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
                Else
                    ' 未找到则提示
                    MsgBox "文件 " & fnameCurFile & " 中未找到名为'Data Tab'的工作表，已跳过该文件", vbExclamation, "提示"
                End If
                
                Set targetSheet = Nothing ' 重置变量
                wbkSrcBook.Close SaveChanges:=False
            Next
 
            Application.ScreenUpdating = True
            Application.Calculation = xlCalculationAutomatic
 
            MsgBox "Processed " & countFiles & " files" & vbCrLf & "Merged " & countSheets & " worksheets", Title:="Merge Excel files"
        End If
    Else
        MsgBox "No files selected", Title:="Merge Excel files"
    End If
End Sub

关键修改说明 #

• 原代码中wbkSrcBook.Sheets(1).Copy是提取第一个工作表的核心代码，修改这一行即可实现不同需求：
  • 提取最后一个工作表：替换为wbkSrcBook.Sheets(wbkSrcBook.Sheets.Count).Copy
  • 提取指定名称工作表：先通过Sheets("Data Tab")定位目标表，再执行复制操作
• 方案2中加入了错误处理，避免因部分文件缺少指定工作表导致程序崩溃，同时给出明确提示。

内容的提问来源于stack exchange，提问作者David Mitchell