VBA复制工作簿并在工作表之间保留相对单元格引用

Question

我有一个有多张工作表的工作簿，需要一个宏按钮来保存它的副本并删除名为"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:UsersTomDesktop" & .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

Answer 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:UsersTomDesktop" & .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