VBA复制工作簿并保持工作表之间的相对单元格引用答案

【问题标题】：VBA to copy workbook and keep relative cell references between sheetsVBA复制工作簿并保持工作表之间的相对单元格引用
【发布时间】：2021-04-10 01:32:13
【问题描述】：

我的工作簿有多个工作表，需要一个宏按钮来保存它的副本并删除名为“CSG”的工作表。这很容易做到，但问题是所有单元格引用都指向原始工作簿。在帮助下，已尝试通过名称管理器解决该问题并破坏所有链接代码。现在的问题是它破坏了新工作簿中的所有引用并仅复制原始工作簿中的值。

例如，在原始工作簿中 sheet1 单元格 A1 的值为 10，sheet2 单元格 A1 具有单元格引用“='sheet1'!A1”。当我制作新副本时，两个单元格的值都为 10，但引用不再存在。有没有办法在不引用原始工作簿的情况下将这些引用保留在工作簿中？下面是当前使用的代码。

Sub SaveTest()
Dim x           As Integer
    Dim FileName    As String, FilePath As String
    Dim NewWorkBook As Workbook, OldWorkBook As Workbook
   
    Set OldWorkBook = ThisWorkbook
   
    With Application
        .ScreenUpdating = False: .DisplayAlerts = False
    End With
   
    On Error Resume Next
    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 & "\"
   
    For x = 2 To OldWorkBook.Worksheets.Count
        With OldWorkBook.Worksheets(x)
            If Not NewWorkBook Is Nothing Then
                .Copy after:=NewWorkBook.Worksheets(NewWorkBook.Worksheets.Count)
            Else
                .Copy
                Set NewWorkBook = ActiveWorkbook
            End If
        End With
    Next x
    
    DeleteBadNames NewWorkBook
    BreakAllLinks NewWorkBook
    UpdateNameManager NewWorkBook
    
    NewWorkBook.SaveAs FilePath & FileName, 51
       
     
myerror:
   If Not NewWorkBook Is Nothing Then NewWorkBook.Close False
    With Application
        .ScreenUpdating = True: .DisplayAlerts = True
    End With
    If Err <> 0 Then MsgBox (Error(Err)), 48, "Error"

End Sub

【问题讨论】：

您可以执行查找/替换以用空白字符串替换每个公式中的旧工作簿名称，而不是断开链接。然后公式将被保留。
先用新名称保存工作簿然后删除不需要的工作表有什么问题？此外，在复制多个相互引用的工作表时，创建一个包含它们名称的数组并使用它来一次性复制它们是至关重要的。然后引用将按预期工作。

标签： excel vba

【解决方案1】：

创建工作簿副本

Option Explicit

Sub SaveTest()
   
    Dim OldWorkBook As Workbook: Set OldWorkBook = ThisWorkbook
    
    Dim WorkSheetNames() As String
    Dim FilePath As String
    Dim FileName As String
    
    With OldWorkBook.Worksheets("CSG")
        ReDim WorkSheetNames(1 To .Parent.Worksheets.Count)
        FilePath = "C:\Users\Tom\Desktop\" & .Range("B1").Value & " " _
            & .Range("B2").Value
        FileName = .Range("B1").Value & " " & .Range("B2").Value & ".xlsx"
    End With
   
    On Error Resume Next
    MkDir FilePath
    On Error GoTo 0
    FilePath = FilePath & "\"
   
    Dim ws As Worksheet
    Dim n As Long
    
    For Each ws In OldWorkBook.Worksheets
        n = n + 1
        WorkSheetNames(n) = ws.Name
    Next ws
    
    Application.ScreenUpdating = False
    
    OldWorkBook.Worksheets(WorkSheetNames).Copy
    
    With ActiveWorkbook ' new workbook
        Application.DisplayAlerts = False
        .Worksheets("CSG").Delete
        .SaveAs FilePath & FileName, 51 ' xlOpenXMLWorkbook
        Application.DisplayAlerts = True
        '.Close SaveChanges:=False
    End With
    
    Application.ScreenUpdating = True
    
End Sub

【讨论】：