如何重新创建工作表并保持参考有效？

Question

我有一个客户手里拿着一堆应该标准化的工作表。它们是通过导入 CSV 文件创建的。基本上，我需要在从另一个选项卡引用它们时替换当前的手册表，而不会破坏当前的引用。

我已将问题简化为包含 2 张纸的单个工作簿。 Sheet1 单元格 A1 引用 Sheet2 单元格 A1，其中包含字符串“Sheet2A1CellData”

下面注释掉的所有内容都已尝试过，包括 Application.Volatile 和 Application.Calculation。

Option Explicit
Sub TestSheet2Delete()
  Dim TmpSheet2 As Worksheet: Set TmpSheet2 = Sheets("Sheet2")

  'Application.Volatile

  If TmpSheet2 Is Nothing Then
    Exit Sub
  End If

  'Application.Calculation = False

  Application.DisplayAlerts = False
  TmpSheet2.Delete
  Application.DisplayAlerts = True

  Set TmpSheet2 = Worksheets.Add(After:=Sheets("Sheet1"))

  If TmpSheet2 Is Nothing Then
    Exit Sub
  End If

  TmpSheet2.Name = "Sheet2"
  TmpSheet2.Range("A1").Value = "Sheet2A1CellData"

  'Application.Calculation = True
End Sub

Sheet1 A1 最初是 =Sheet2!A1。当我从 VBE 运行上述函数时，Sheet1 单元格 A1 设置为 =#REF!A1。

更换工作表后如何保持参考有效？

显然，现实世界的问题要大得多，重新导入 CSV 数据需要更新 132,000 个单元格。 6000 行 x 22 列。

感谢您的帮助。

Answer 1

感谢您提出一个非常好的问题。

首先免责声明：这不是直接的解决方案，而是多年前我们不得不采用的解决方法。

在我的工作场所遇到过完全相同的问题问题（字面意思是让我们拔毛），我们也试图去iNDIRECT。但由于工作表中的公式很复杂，我们未能用INDIRECT 替换它们。因此，我们不是用冗长的手动替换工作表中的数百个公式，而是插入一个临时表并更改对该表的公式引用。导入新工作表并将其重命名为旧工作表的名称后，公式恢复为原始。 我试图重现使用的代码（因为我现在无法访问相同的文件）。我们只用了Sub ChangeFormulas，这里我用的和你的代码一样。

Option Explicit
Sub TestSheet2Delete()
Dim Wb As Workbook
Dim Ws As Worksheet, Ws1 As Worksheet, Ws2 As Worksheet
Dim Xstr As String, Ystr As String
Set Wb = ThisWorkbook
Set Ws = Wb.Sheets("Sheet1")

Xstr = "Sheet2"
Ystr = "TempSheetX"
Set Ws1 = Wb.Sheets(Xstr)

Set Ws2 = Worksheets.Add(After:=Ws)
Ws2.Name = Ystr
DoEvents
ChangeFormulas Ws, Xstr, Ystr

Application.DisplayAlerts = False
Ws1.Delete

' Now again add another sheet with Old name and change formulas back to Original
Set Ws1 = Worksheets.Add(After:=Ws)
Ws1.Name = Xstr
DoEvents
ChangeFormulas Ws, Ystr, Xstr
Ws2.Delete

Application.DisplayAlerts = True

End Sub
Sub ChangeFormulas(Ws As Worksheet, Xstr As String, Ystr As String)
Dim Rng As Range, C As Range, FirstAddress As String
Set Rng = Ws.UsedRange
With Rng
    Set C = .Find(What:=Xstr, LookIn:=xlFormulas)
    If Not C Is Nothing Then
        FirstAddress = C.Address
        Do
            C.Formula = Replace(C.Formula, Xstr, Ystr)
            Set C = .FindNext(C)
            If C Is Nothing Then Exit Do
            If C.Address = FirstAddress Then Exit Do
        Loop
    End If
End With

End Sub

另一个最简单的解决方法是根本不删除工作表并导入 CSV 并将整个工作表复制到有问题的工作表上。 但是，这完全取决于涉及 CSV 和所有内容的实际工作条件。

Answer 2

在我发布后（当然 :-)），此链接出现在右侧：Preserve references，建议使用 INDIRECT。我现在已将 Sheet1 A1 更改为 =INDIRECT("Sheet2!"&"A1")。

我不确定为什么需要链接中建议的命名范围。上面的间接调用似乎在没有命名范围的情况下工作。

如果这适用于较大的项目，我会将其标记为完成。

Answer 3

我的原始答案不适用于非连续单元格。但是，我真的很喜欢 Range to Variants 然后回到 Range 模式。非常快。所以我将我原来的答案改写成更可重用的代码，使用非连续单元进行测试。

Function PreserveFormulaeInVariantArr(ByVal aWorksheet As Worksheet, _
                                      ByVal aIsNoFormulaErr As Boolean, _
                                      ByRef aErrStr As String) As Variant
  Dim TmpRange As Range
  Dim TmpAreaCnt As Long
  Dim TmpVarArr As Variant
  Dim TmpAreaVarArr As Variant

  PreserveFormulaeInVariantArr = Empty

  If aWorksheet Is Nothing Then
    aErrStr = "PreserveFormulaeInVariantArr: Worksheet is Nothing."
    Exit Function
  End If

  Err.Clear
  On Error Resume Next
  Set TmpRange = aWorksheet.Cells.SpecialCells(xlCellTypeFormulas)
  If Err.Number <> 0 Then 'No Formulae.
    PreserveFormulaeInVariantArr = Empty
    If aIsNoFormulaErr Then
      aErrStr = "PreserveFormulaeInVariantArr: No cells with formulae."
    End If
    Exit Function
  End If

  TmpAreaVarArr = Empty
  On Error GoTo ErrLabel
  ReDim TmpVarArr(1 To TmpRange.Areas.Count, 1 To 2)

  For TmpAreaCnt = LBound(TmpVarArr) To UBound(TmpVarArr)
    TmpVarArr(TmpAreaCnt, 1) = TmpRange.Areas(TmpAreaCnt).Address 'Set 1st Element to Range
    TmpAreaVarArr = TmpRange.Areas(TmpAreaCnt).Formula 'Left TmpArrVarArr for Debugging
    TmpVarArr(TmpAreaCnt, 2) = TmpAreaVarArr 'Creates Jagged Array
  Next TmpAreaCnt

  PreserveFormulaeInVariantArr = TmpVarArr

  Exit Function
ErrLabel:
  aErrStr = "PreserveFormulaeInVariantArr - Error Number: " + CStr(Err.Number) + " Error Description: " + Err.Description
End Function

Function RestoreFormulaeFromVariantArr(ByVal aWorksheet As Worksheet, _
                                       ByVal aIsEmptyAreaVarArrError As Boolean, _
                                       ByVal aAreaVarArr As Variant, _
                                       ByRef aErrStr As String) As Boolean
  Dim TmpVarArrCnt As Long
  Dim TmpRange As Range
  Dim TmpDim1Var As Variant
  Dim TmpDim2Var As Variant
  Dim TmpDim2Cnt As Long
  Dim TmpDim2UBound As Long

  RestoreFormulaeFromVariantArr = False

  On Error GoTo ErrLabel

  If aWorksheet Is Nothing Then
    Exit Function
  End If

  If IsEmpty(aAreaVarArr) Then
    If aIsEmptyAreaVarArrError Then
      aErrStr = "RestoreFormulaeFromVariantArr: Empty array passed."
    Else
      RestoreFormulaeFromVariantArr = True
    End If
    Exit Function
  End If

  For TmpVarArrCnt = 1 To UBound(aAreaVarArr)
    TmpDim1Var = aAreaVarArr(TmpVarArrCnt, 1) 'This is always the range.
    TmpDim2Var = aAreaVarArr(TmpVarArrCnt, 2) 'This can be a Variant or Variant Array
    aWorksheet.Range(TmpDim1Var).Formula = TmpDim2Var
  Next TmpVarArrCnt

  RestoreFormulaeFromVariantArr = True

  Exit Function
ErrLabel:
  aErrStr = "PreserveFormulaeInVariantArr - Error Number: " + CStr(Err.Number) + " Error Description: " + Err.Description
End Function

Sub TestPreserveFormulaeInVariantArr()
  Dim TmpPreserveFormulaeArr As Variant
  Dim TmpErrStr As String
  Dim TmpIsNoFormulaErr As Boolean: TmpIsNoFormulaErr = True 'Change If Desired
  Dim TmpEmptySheet1 As Boolean: TmpEmptySheet1 = False 'Change If Desired
  Dim TmpSheet1 As Worksheet: Set TmpSheet1 = Sheets("Sheet1")
  Dim TmpSheet2 As Worksheet

  Err.Clear
  On Error Resume Next
  Set TmpSheet2 = Sheets("Sheet2")
  On Error GoTo 0

  'Always Delete Sheet2
  If (TmpSheet2 Is Nothing) = False Then
    Application.DisplayAlerts = False
    TmpSheet2.Delete
    Application.DisplayAlerts = True
    Set TmpSheet2 = Nothing
  End If

  If TmpSheet2 Is Nothing Then
    Set TmpSheet2 = Worksheets.Add(After:=Sheets("Sheet1"))
    TmpSheet2.Name = "Sheet2"
    TmpSheet2.Range("A1") = "Sheet2A1"
    TmpSheet2.Range("B1") = "Sheet2A1"
    TmpSheet2.Range("C4") = "Sheet2C4"

    If TmpEmptySheet1 Then
      TmpSheet1.Cells.ClearContents
    Else
      TmpSheet1.Range("A1").Formula = "=Sheet2!A1"
      TmpSheet1.Range("B1").Formula = "=Sheet2!B1"
      TmpSheet1.Range("C4").Formula = "=Sheet2!C4"
    End If
  End If

  TmpPreserveFormulaeArr = PreserveFormulaeInVariantArr(TmpSheet1, TmpIsNoFormulaErr, TmpErrStr)

  If TmpErrStr <> "" Then
    MsgBox TmpErrStr
    Exit Sub
  End If

  'Break Formulae and Cause #Ref Violation
  Application.DisplayAlerts = False
  TmpSheet2.Delete
  Application.DisplayAlerts = True

  'Add Sheet2 Back
  Set TmpSheet2 = Worksheets.Add(After:=Sheets("Sheet1"))
  TmpSheet2.Name = "Sheet2"
  TmpSheet2.Range("A1") = "Sheet2A1"
  TmpSheet2.Range("B1") = "Sheet2A1"
  TmpSheet2.Range("C4") = "Sheet2C4"

  'Restore Formulas Back to Sheet1
  If RestoreFormulaeFromVariantArr(TmpSheet1, TmpIsNoFormulaErr, TmpPreserveFormulaeArr, TmpErrStr) = False Then
    MsgBox TmpErrStr
    Exit Sub
  End If
End Sub

TestPreserveFormulaeInVariantArr 可以在 VBE 中运行，并带有设置空值的选项。任何 cmet 表示赞赏。