合并VW开头Excel工作簿至AEKO时仅首个工作表有数据问题排查

我有多个以VW开头的Excel文件，想要把其中所有含数据的工作表导入新建工作簿AEKO。现有VBA宏支持选择文件夹，但运行后只有首个文件的工作表复制成功，其余工作表虽然重命名了但内容是空的。

以下是使用的VBA代码：

Sub MergeWorkbooks()
    
        Dim myFolder As String
        Dim myFile As String
        Dim myPath As String
        Dim myExtension As String
        Dim i As Integer
        Dim j As Integer
        Dim myWorkbook As Workbook    
        Dim mergeWorkbook As Workbook    
        Dim sheetName As String
    
        'Prompt user to select folder
        With Application.FileDialog(msoFileDialogFolderPicker)    
            .Title = "Select a folder with Excel workbooks"    
            .AllowMultiSelect = False    
            If .Show <> -1 Then Exit Sub    
            myFolder = .SelectedItems(1)    
        End With      
    
        'Set path and extension    
        myPath = myFolder & "\"    
        myExtension = "*.xlsx"       
    
        'Create new workbook for merging    
        Set mergeWorkbook = Workbooks.Add
    
        'Loop through files in folder    
        myFile = Dir(myPath & myExtension)
    
        Do While myFile <> ""    
    
            'Open only workbooks with name starting with "VW"    
            If Left(myFile, 2) = "VW" Then    
                Set myWorkbook = Workbooks.Open(myPath & myFile)    
                'Rename sheets with Excel file name without extension    
                sheetName = Left(myFile, Len(myFile) - 5)
    
                For i = 1 To myWorkbook.Sheets.Count    
                    myWorkbook.Sheets(i).Name = sheetName    
                Next i
    
                'Copy data to merge workbook    
                myWorkbook.Sheets.Copy After:=mergeWorkbook.Sheets(mergeWorkbook.Sheets.Count)    
                myWorkbook.Close SaveChanges:=False    
            End If
    
            myFile = Dir    
        Loop    
       
    
        'Delete Sheet1 from merged workbook    
        Application.DisplayAlerts = False 'suppress alert        
        On Error Resume Next              'continue if Sheet1 is not found    
        mergeWorkbook.Sheets("Sheet1").Delete    
        On Error GoTo 0                   'resume normal error handling    
        Application.DisplayAlerts = True  'turn alert back on       
    
        'Save merged workbook with name "AEKO" in the selected folder    
        mergeWorkbook.SaveAs myPath & "AEKO.xlsx"       
    
        'Close merged workbook    
        mergeWorkbook.Close    
        'Open the new workbook just created    
        Workbooks.Open myPath & "AEKO.xlsx"    
       
End Sub

问题原因分析 #

• 重复工作表名称引发隐性错误：代码给当前打开的工作簿所有工作表设置同一个sheetName（文件名去掉后缀），但Excel不允许同一工作簿内存在同名工作表。处理第二个及以后的工作表时，重命名操作会触发错误，因无错误处理机制，代码跳过该操作，后续Copy操作也会因之前的异常导致复制出空工作表。
• 文件名提取逻辑局限性：Left(myFile, Len(myFile)-5)仅适配.xlsx后缀（长度为5），若遇到.xlsm等其他格式文件，会导致文件名提取错误。

修复后的代码 #

Sub MergeWorkbooks()
    Dim myFolder As String
    Dim myFile As String
    Dim myPath As String
    Dim myExtension As String
    Dim i As Integer
    Dim myWorkbook As Workbook
    Dim mergeWorkbook As Workbook
    Dim baseSheetName As String

    ' 选择存放Excel文件的文件夹
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "选择存放Excel文件的文件夹"
        .AllowMultiSelect = False
        If .Show <> -1 Then Exit Sub
        myFolder = .SelectedItems(1)
    End With

    myPath = myFolder & "\"
    myExtension = "*.xlsx"

    ' 创建合并用的空白工作簿
    Set mergeWorkbook = Workbooks.Add

    ' 遍历文件夹中的所有xlsx文件
    myFile = Dir(myPath & myExtension)

    Do While myFile <> ""
        ' 仅处理以VW开头的文件
        If Left(myFile, 2) = "VW" Then
            Set myWorkbook = Workbooks.Open(myPath & myFile)
            ' 提取文件名（自动适配不同后缀长度）
            baseSheetName = Left(myFile, InStrRev(myFile, ".") - 1)

            ' 给每个工作表添加序号，避免同一工作簿内重名
            For i = 1 To myWorkbook.Sheets.Count
                myWorkbook.Sheets(i).Name = baseSheetName & "_" & i
            Next i

            ' 将当前工作簿的所有工作表复制到合并工作簿末尾
            myWorkbook.Sheets.Copy After:=mergeWorkbook.Sheets(mergeWorkbook.Sheets.Count)
            ' 关闭源文件，不保存修改
            myWorkbook.Close SaveChanges:=False
        End If
        ' 读取下一个文件
        myFile = Dir
    Loop

    ' 删除合并工作簿默认的Sheet1
    Application.DisplayAlerts = False
    On Error Resume Next
    mergeWorkbook.Sheets("Sheet1").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True

    ' 保存合并后的工作簿为AEKO.xlsx
    mergeWorkbook.SaveAs myPath & "AEKO.xlsx"
    mergeWorkbook.Close
    ' 打开刚创建的合并工作簿
    Workbooks.Open myPath & "AEKO.xlsx"
End Sub

修复说明 #

1. 避免工作表重名：给每个工作表名称添加序号（如VW001_1、VW001_2），确保同一工作簿内的工作表名称唯一，消除重命名错误。
2. 通用文件名提取：使用InStrRev(myFile, ".")定位文件后缀位置，自动适配不同长度的文件后缀，避免文件名提取错误。
3. 清理冗余代码：移除未使用的变量j，优化代码结构。

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