VBA复制工作簿时保留工作表间内部单元格引用的技术问询

我完全理解你的困扰——本来只是想存个副本删掉特定工作表，结果要么引用全指向原文件，要么内部公式全变数值，两头为难。咱们来拆解问题，然后给出精准的解决方案。

问题根源 #

你之前用的BreakAllLinks和相关断链逻辑太粗暴了，它不分内部还是外部引用，直接把所有链接都断开成了值。咱们需要的是只清理指向原工作簿的外部引用，同时保留新工作簿自身的工作表间引用。

修改后的宏代码 #

下面是调整后的完整代码，核心是新增了精准处理外部引用的逻辑，替换掉指向原工作簿的路径，而不是一刀切断所有链接：

Sub SaveTest()
    Dim x As Integer
    Dim FileName As String, FilePath As String
    Dim NewWorkBook As Workbook, OldWorkBook As Workbook
    Dim OldWBName As String
    
    Set OldWorkBook = ThisWorkbook
    OldWBName = "'" & OldWorkBook.Name & "'" ' 记录原工作簿名称，用于匹配外部引用
    
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False ' 额外禁用事件，避免不必要的弹窗或触发其他宏
    End With
    
    On Error Resume Next
    ' 获取保存路径和文件名（从CSG工作表读取）
    With OldWorkBook.Sheets("CSG")
        FilePath = "C:\Users\Tom\Desktop\" & .Range("B1").Value & " " & .Range("B2").Value
        FileName = .Range("B1").Value & " " & .Range("B2").Value & ".xlsx"
    End With
    MkDir FilePath ' 创建文件夹，存在则忽略错误
    On Error GoTo -1
    On Error GoTo myerror
    
    FilePath = FilePath & "\" ' 修正路径分隔符
    
    ' 复制除CSG外的所有工作表到新工作簿
    For x = 1 To OldWorkBook.Worksheets.Count
        If OldWorkBook.Worksheets(x).Name <> "CSG" Then
            If Not NewWorkBook Is Nothing Then
                OldWorkBook.Worksheets(x).Copy after:=NewWorkBook.Worksheets(NewWorkBook.Worksheets.Count)
            Else
                OldWorkBook.Worksheets(x).Copy
                Set NewWorkBook = ActiveWorkbook
            End If
        End If
    Next x
    
    ' 关键步骤：修复外部引用，只替换指向原工作簿的部分，保留内部引用
    FixExternalReferences NewWorkBook, OldWBName
    
    ' 保存新工作簿
    NewWorkBook.SaveAs FilePath & FileName, 51 ' 51对应.xlsx格式
    
myerror:
    ' 清理资源，恢复Excel设置
    If Not NewWorkBook Is Nothing Then
        NewWorkBook.Close SaveChanges:=False ' 因为已经SaveAs过，这里直接关闭
    End If
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .EnableEvents = True
    End With
    If Err <> 0 Then
        MsgBox "错误：" & Error(Err), vbExclamation, "操作失败"
    End If
End Sub

' 自定义函数：修复新工作簿中的外部引用，替换原工作簿的名称为空
Private Sub FixExternalReferences(targetWB As Workbook, oldWBName As String)
    Dim ws As Worksheet
    Dim nm As Name
    Dim oldRefPrefix As String
    
    ' 构建原工作簿的引用前缀（比如 '[原工作簿.xlsx]'）
    oldRefPrefix = "[" & Replace(oldWBName, "'", "") & "]"
    
    ' 处理每个工作表的单元格公式
    For Each ws In targetWB.Worksheets
        ' 替换公式中指向原工作簿的引用
        ws.UsedRange.Replace What:=oldRefPrefix, Replacement:="", LookAt:=xlPart, MatchCase:=False
        ' 处理可能的单引号包裹情况（比如 '原工作簿.xlsx'!Sheet1!A1）
        ws.UsedRange.Replace What:=oldWBName & "!", Replacement:="", LookAt:=xlPart, MatchCase:=False
    Next ws
    
    ' 处理名称管理器中的外部引用
    For Each nm In targetWB.Names
        If InStr(nm.RefersTo, oldRefPrefix) > 0 Or InStr(nm.RefersTo, oldWBName) > 0 Then
            ' 替换名称引用中的原工作簿标识
            nm.RefersTo = Replace(nm.RefersTo, oldRefPrefix, "")
            nm.RefersTo = Replace(nm.RefersTo, oldWBName & "!", "")
        End If
    Next nm
End Sub

代码关键说明 #

• 精准复制工作表：循环时直接跳过名为"CSG"的工作表，不需要后续删除，更高效。
• 保留内部引用：FixExternalReferences函数只替换公式和名称中指向原工作簿的标识（比如[原工作簿.xlsx]或'原工作簿.xlsx'!），把这些部分清空后，原本的跨表引用就变成了新工作簿内部的引用（比如[原工作簿.xlsx]Sheet1!A1会变成Sheet1!A1）。
• 恢复Excel设置：新增了EnableEvents = False避免触发其他宏或事件，操作完成后全部恢复。

测试验证 #

运行这个宏后，你可以检查新工作簿：

• Sheet2的A1单元格依然保留公式='Sheet1'!A1，而不是纯数值
• 所有原本指向原工作簿的外部引用都被修正为新工作簿内部的引用
• "CSG"工作表不会出现在新工作簿中

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