如何用公式批量复制Excel所有工作表？VBA运行异常求助

异常原因 #

1. 工作表名称未加单引号包裹：若原工作表名称包含空格、特殊字符（如&、#、@等），公式中直接使用工作表名!单元格地址会被Excel误判为外部工作簿引用，触发文件资源管理器弹窗要求定位外部文件。
2. 遍历动态集合导致冗余处理：For Each ws In ThisWorkbook.Worksheets遍历的是动态的工作表集合，每新建一个_c后缀的工作表，集合会自动新增成员，导致循环会处理这些刚创建的新表，生成不必要的_c_c后缀工作表，同时加剧引用错误。

修复后的代码 #

Sub CopyAllSheets()
    OptimizeCode
    
    Dim ws As Worksheet
    Dim newSheet As Worksheet
    Dim wsName As String
    Dim newSheetName As String
    Dim cellAddress As String
    Dim formulaText As String
    ' 用数组存储原工作表名称，避免遍历动态集合
    Dim originalSheets() As String
    Dim i As Integer
    
    ' 先收集所有原工作表名称到静态数组
    ReDim originalSheets(1 To ThisWorkbook.Worksheets.Count)
    For i = 1 To ThisWorkbook.Worksheets.Count
        originalSheets(i) = ThisWorkbook.Worksheets(i).Name
    Next i
    
    ' 遍历静态数组中的原工作表
    For i = 1 To UBound(originalSheets)
        wsName = originalSheets(i)
        Set ws = ThisWorkbook.Worksheets(wsName)
        
        newSheetName = wsName & "_c"
    
        ' 检查新表是否存在，存在则删除
        On Error Resume Next
        Set newSheet = ThisWorkbook.Worksheets(newSheetName)
        On Error GoTo 0
    
        If Not newSheet Is Nothing Then
            Application.DisplayAlerts = False
            newSheet.Delete
            Application.DisplayAlerts = True
        End If
    
        ' 新建工作表
        Set newSheet = ThisWorkbook.Worksheets.Add(After:=ws)
        newSheet.Name = newSheetName
    
        ' 批量写入公式（优化：避免逐个单元格循环，提升效率）
        With ws.UsedRange
            cellAddress = .Address(RowAbsolute:=False, ColumnAbsolute:=False)
            ' 给工作表名称添加单引号，处理含特殊字符的表名
            formulaText = "=IF('" & wsName & "'!" & cellAddress & "="""","""",'" & wsName & "'!" & cellAddress & ")"
            newSheet.Range(cellAddress).Formula = formulaText
        End With
    Next i

    DefaultSettings
End Sub

额外优化说明 #

• 静态数组遍历：先将所有原工作表名称存入数组，避免遍历动态的Worksheets集合，防止处理新建的_c后缀表。
• 单引号包裹表名：公式中用'工作表名'格式引用，彻底解决特殊名称导致的外部引用错误。
• 批量写入公式：直接对整个UsedRange写入公式，替代逐个单元格循环，大幅提升运行效率。

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