用命名范围替换坐标参考

Question

我有一个巨大的 xlsm 文件，其中包含大约 10,000 个命名范围和 22 个工作表。我需要用相应的命名范围替换公式中的坐标引用。我试过这个脚本：

Sub Ref2Named()
    Dim Nm As Name
    For Each Nm In ThisWorkbook.Names
        ActiveSheet.Cells.ApplyNames Names:=Nm.Name
    Next Nm
End Sub

但它返回错误 1004 Microsoft Excel 找不到任何要替换的引用。

Answer 1

首先，整个代码可能会被单行替换：

ActiveSheet.Cells.ApplyNames

根本不需要子。 documentation 将 name 参数描述为“要应用的名称数组。如果省略此参数，则工作表上的所有名称都将应用于该范围。”但是 - 不清楚这是否会应用 工作簿 名称集合中的每个名称。

如果您确实需要一个子 -- 请注意文档中提到使用名称的 array。为此，您可以使用Array 函数：

Sub Ref2Named()
    Dim Nm As Name
    On Error Resume Next
    For Each Nm In ThisWorkbook.Names
        ActiveSheet.Cells.ApplyNames Names:=Array(Nm.Name)
    Next Nm
    On Error GoTo 0
End Sub

我不是On Error Resume Next 的粉丝，但在这种情况下，我认为这是合适的，因为如果名称实际上没有出现在该范围内的任何公式中，ApplyNames 似乎会失败。

如果名称是对其他工作表中范围的引用，则似乎是ApplyNames 的限制，它仅将名称替换为对当前工作表的引用。一种解决方法是使用查找和替换：

Sub Ref2Named()
    Dim Nm As Name, ref As String
    With ActiveSheet.Cells
        For Each Nm In ThisWorkbook.Names
            On Error Resume Next
                .ApplyNames Names:=Array(Nm.Name)
            On Error GoTo 0
            ref = Nm.RefersTo
            ref = Mid(ref, 2)
            .Replace What:=ref, Replacement:=Nm.Name
            ref = Replace(ref, "$", "")
            .Replace What:=ref, Replacement:=Nm.Name
        Next Nm
    End With
End Sub

例如，如果名称 test 引用 Sheet2!$A$1，那么我首先将此引用分配给 ref（在去除 RefersTo 中的前导 = 之后）。然后，如果 Sheet1 中的任何单元格（假设这是活动工作表）具有 Sheet2!A1 或 Sheet2$A$1，则将在公式中将其替换为 test。我仍然保留 ApplyNames 作为本地名称。

要应用于工作簿中的所有工作表，请尝试：

Sub ApplyAllNames()
    Dim ws As Worksheet, Nm As Name, ref As String
    For Each ws In ThisWorkbook.Worksheets
        With ws.Cells
            For Each Nm In ThisWorkbook.Names
                On Error Resume Next
                    .ApplyNames Names:=Array(Nm.Name)
                On Error GoTo 0
                ref = Nm.RefersTo
                ref = Mid(ref, 2)
                .Replace What:=ref, Replacement:=Nm.Name
                ref = Replace(ref, "$", "")
                .Replace What:=ref, Replacement:=Nm.Name
            Next Nm
        End With
    Next ws
End Sub

如果您的某些名字是列绝对但不是绝对，此代码需要调整。

编辑时：这是一个应该能够处理大型电子表格的版本。要使用它，请添加对Microsoft Scripting Runtime 的引用（在VBA 编辑器中的Tools/References 下）：

Sub ApplyAllNames()
    Dim D As New Dictionary
    Dim C As Collection
    Dim ws As Worksheet, sh As Worksheet
    Dim A As Variant, v As Variant
    Dim nm As Name, i As Long, n As Long, ref As String
    Dim R As Range

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    For Each ws In Worksheets
        Set C = New Collection
        D.Add ws.Name, C
    Next ws
    For Each nm In Names
        ref = Split(nm.RefersTo, "!")(0) '=sheet name of ref
        ref = Mid(ref, 2) 'get rid of "="
        D(ref).Add nm
    Next nm

    'replace each collection of names
    'by an array sorted in order of descending length
    Set sh = Worksheets.Add
    For Each ws In Worksheets
        If ws.Name <> sh.Name Then
            Set C = D(ws.Name)
            n = C.Count
            If n = 0 Then
                D(ws.Name) = Array()
            Else
                ReDim A(1 To n, 1 To 2)
                For i = 1 To n
                    A(i, 1) = C(i).Name
                    A(i, 2) = Len(C(i).RefersTo)
                Next i
                Set R = sh.Range(sh.Cells(1, 1), sh.Cells(n, 2))
                R.Value = A
                R.Sort key1:=Range("B1:B" & n), order1:=xlDescending, Header:=xlNo
                A = R.Value
                D(ws.Name) = A
            End If
        End If
    Next ws
    Application.DisplayAlerts = False
    sh.Delete
    Application.DisplayAlerts = True

    'now loop over sheets and name array
    For Each ws In Sheets
        For Each sh In Sheets
            A = D(sh.Name)
            If ws.Name = sh.Name Then
                On Error Resume Next
                    For i = 1 To UBound(A)
                        ws.Cells.ApplyNames A(i, 1)
                    Next i
                On Error GoTo 0
            Else
                For i = 1 To UBound(A)
                    Set v = Names(A(i, 1))
                    ref = Mid(v.RefersTo, 2) 'name with "=" removed
                    ws.Cells.Replace ref, v.Name
                    ref = Replace(ref, "$", "")
                    ws.Cells.Replace ref, v.Name
                Next i
            End If
            Debug.Print ws.Name & " <- " & sh.Name
            DoEvents
        Next sh
    Next ws
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
End Sub

代码根据包含名称所指范围的工作表将名称拆分成堆。然后它逐步执行应用程序，并在即时窗口中显示进度指示器。例如，Sheet3 <- Sheet5 表示引用 Sheet5 的名称已应用于 Sheet 3 中的公式。修复了一个细微的错误。某些范围的地址可能是其他范围地址的前缀。较早的代码可能例如替换单元格中的"Sheet2!A5" in the middle of a formula involving"Sheet2!A55by a name (say "foo_bar") leaving"Sheet2!foo_bar5"`。修复方法是按参考长度递减的顺序排序名称。

我在一个包含 11 个工作表、10,000 个命名范围和 5,000 个公式的工作簿上尝试了上述代码，每个公式引用 5 个随机选择的单元格，因此需要进行超过 20,000 次替换。大约需要 4 分钟。如果这不起作用，下一步自然是使用正则表达式从每个公式中提取单元格引用，并将这些引用与名称引用字典进行比较。