Mac环境下VBA宏无法复制指定工作表至新工作簿求助

你的代码存在几个关键问题导致工作表复制失败，以下是修正后的完整代码，同时整合了让用户选择文件夹的功能：

Sub CopyWorkingSheets()
    Dim sourceFolder As String
    Dim destinationFile As String
    Dim wbSource As Workbook
    Dim wsSource As Worksheet
    Dim wbDestination As Workbook
    Dim fileExtension As String
    Dim fileName As String
    Dim sheetName As String
    
    ' 让用户选择目标文件夹
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "选择包含工作簿的文件夹"
        If .Show = -1 Then
            sourceFolder = .SelectedItems(1)
        Else
            MsgBox "未选择文件夹，宏终止"
            Exit Sub
        End If
    End With
    
    ' 处理文件夹路径（确保结尾带斜杠，Mac系统需要）
    If Right(sourceFolder, 1) <> "/" Then
        sourceFolder = sourceFolder & "/"
    End If
    
    fileExtension = "*.xlsx"
    destinationFile = sourceFolder & "Working Copies.xlsx"
    
    ' 新建目标工作簿
    Set wbDestination = Workbooks.Add
    
    ' 遍历文件夹中的xlsx文件
    fileName = Dir(sourceFolder & fileExtension)
    Do While fileName <> ""
        ' 打开源工作簿
        Set wbSource = Workbooks.Open(sourceFolder & fileName)
        
        ' 检查是否存在"Working Copy"工作表
        On Error Resume Next
        Set wsSource = wbSource.Sheets("Working Copy")
        On Error GoTo 0
        
        If Not wsSource Is Nothing Then
            ' 直接将源工作表复制到目标工作簿末尾
            wsSource.Copy After:=wbDestination.Sheets(wbDestination.Sheets.Count)
            ' 处理表名：去掉原文件的.xlsx扩展名
            sheetName = Left(fileName, Len(fileName) - 5) & " - Working Copy"
            ' 避免表名重复（如果有同名文件）
            On Error Resume Next
            wbDestination.Sheets(wbDestination.Sheets.Count).Name = sheetName
            If Err.Number <> 0 Then
                wbDestination.Sheets(wbDestination.Sheets.Count).Name = sheetName & "(" & wbDestination.Sheets.Count & ")"
            End If
            On Error GoTo 0
            Set wsSource = Nothing ' 重置对象
        End If
        
        ' 关闭源工作簿，不保存
        wbSource.Close SaveChanges:=False
        
        ' 下一个文件
        fileName = Dir()
    Loop
    
    ' 删除新建工作簿默认的空白工作表（如果存在）
    Application.DisplayAlerts = False
    Do While wbDestination.Sheets.Count > 1
        wbDestination.Sheets(1).Delete
    Loop
    Application.DisplayAlerts = True
    
    ' 保存并关闭目标工作簿
    wbDestination.SaveAs destinationFile
    wbDestination.Close SaveChanges:=False
    
    MsgBox "工作表复制完成，已保存至：" & destinationFile
End Sub

关键修改说明： #

1. 文件夹路径处理：

   • 添加了文件夹选择对话框，替换固定路径，满足你整合到现有选择文件夹宏的需求
   • 确保文件夹路径结尾带斜杠，避免Mac系统下路径拼接错误（原代码中sourceFolder & fileExtension会变成/Users/sj/Desktop/Folder*.xlsx，缺少斜杠导致Dir找不到文件）

2. 工作表复制逻辑：

   • 去掉了先新建工作表的冗余步骤，直接用wsSource.Copy After:=wbDestination.Sheets(...)将源表复制到目标工作簿，这是VBA复制工作表的标准用法
   • 添加了工作表存在性检查，避免因源工作簿没有目标表而报错

3. 表名优化：

   • 从原文件名中去掉.xlsx扩展名，让表名更简洁
   • 添加了重复表名的处理，避免因文件名重复导致重命名失败

4. 清理默认工作表：

   • 新建工作簿会默认带1-3个空白表，复制完成后删除多余的空白表，只保留复制过来的工作表

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