Vba 识别同一工作簿中的引用与其他工作簿中的引用

我希望使用Excel VBA代码根据以下参数为字体着色：

• 蓝色：硬编码数字
• 黑色：公式（如总和、vlookup、平均值等）
• 绿色：从同一文件中的另一张图纸链接的编号
• 红色：从外部文件的另一张图纸链接的编号

我已经编写了下面的代码，但它没有区分同一文件中来自另一个单元格/工作表的引用与外部文件中的引用。完成这最后一步需要任何帮助

谢谢

Dim rng As Range, rErr As Range

On Error Resume Next

For Each rng In Intersect(ActiveSheet.UsedRange, Selection)

    If rng.HasFormula Then

        Set rErr = Range(Mid(rng.Formula, 2, Len(rng.Formula) - 1))

        If CBool(Err) Then

            rng.Font.ColorIndex = 1 'black

        Else

            rng.Font.ColorIndex = 3 'red

        End If

        Err = 0

    ElseIf CBool(Len(rng.Value)) Then

        rng.Font.ColorIndex = 5 'blue

    Else

        rng.Font.ColorIndex = xlAutomatic 'default

    End If

Next rng

Set rErr = Nothing

你可以试试这个：

Option Explicit

Sub main()
    Dim cell As Range

    With Intersect(ActiveSheet.UsedRange, Selection)
        On Error Resume Next
        .SpecialCells(xlCellTypeConstants, xlNumbers).Font.ColorIndex = 5 'blue

        For Each cell In .SpecialCells(xlCellTypeFormulas, xlNumbers)
            Select Case True
                Case InStr(cell.Formula, "[") > 0
                    cell.Font.ColorIndex = 3 'red
                Case InStr(Replace(cell.Formula, cell.Parent.Name & "!", ""), "!") > 0
                    cell.Font.ColorIndex = 4  'green
                Case Else
                    cell.Font.ColorIndex = 1 'black
            End Select
        Next
    End With
End Sub

---

我觉得奇怪的是连在一起的细胞很难找到。。。但他们确实是

您不能只搜索

[]

，因为手动键入的链接可能会忽略它们，并且链接仍然可以工作。不能只搜索文件名，因为两个同名文件可能存在于不同的文件夹中。您不能只搜索文件路径或

\

，因为如果链接的工作簿在同一Excel应用程序中打开，链接中将忽略该文件路径

内部联系也带来了类似的问题。你不能依靠搜索

名称

，例如

不久前，我必须识别内部和外部链接的单元格，所以我编写了一些粗略的代码来完成这项工作。这些函数包含在下面的示例中，但我确信会有例外（例如，任何包含与

name

名称相同字符串的公式都将无法通过测试）

我将这些函数作为单独的例程保留，因为它们可能对其他用户有用，但这确实会使项目的代码稍微低效。但这可能是你可以解决的问题

您会注意到，我刚刚使用了

UsedRange

来定义目标范围-您可能需要对此进行修改

Sub RunMe()
    Dim extLinkCells As Range
    Dim intLinkCells As Range
    Dim formulaCells As Range
    Dim numberCells As Range
    Dim cell As Range

    Set numberCells = Sheet1.UsedRange.SpecialCells(xlCellTypeConstants)
    Set extLinkCells = AllExternallyLinkedCells(Sheet1.UsedRange)
    Set intLinkCells = AllInternallyLinkedCells(Sheet1.UsedRange)
    'Pick up the remaining non-linked cells (ie must just be formulas)
    For Each cell In Sheet1.UsedRange.SpecialCells(xlCellTypeFormulas)
        If Intersect(cell, extLinkCells) Is Nothing And Intersect(cell, intLinkCells) Is Nothing Then
            If formulaCells Is Nothing Then
                Set formulaCells = cell
            Else
                Set formulaCells = Union(formulaCells, cell)
            End If
        End If
    Next

    numberCells.Font.Color = vbBlue
    formulaCells.Font.Color = vbBlack
    intLinkCells.Font.Color = vbGreen
    extLinkCells.Font.Color = vbRed
End Sub

Private Function AllInternallyLinkedCells(testRange As Range) As Range

    Dim result As Range, cell As Range
    Dim links() As String
    Dim fileName As String
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim nm As Name
    Dim i As Long

    Set wb = testRange.Parent.Parent

    'Acquire all sheet names apart from this one
    i = 1
    For Each ws In wb.Sheets
        If ws.Name <> testRange.Worksheet.Name Then
            ReDim Preserve links(1 To i)
            links(i) = ws.Name
            Debug.Print "Internal Link"; i; links(i)
            i = i + 1
        End If
    Next
    'Acquire all names that don't refer to this sheet
    For Each nm In wb.Names
        If nm.RefersToRange.Worksheet.Name <> testRange.Worksheet.Name Then
            ReDim Preserve links(1 To i)
            links(i) = nm.Name
            Debug.Print "Internal Link"; i; links(i); " of "; nm.RefersToRange.Worksheet.Name
            i = i + 1
        End If
    Next

    'Test if cell formula matches our list
    For Each cell In testRange.SpecialCells(xlCellTypeFormulas)
        If Exists(cell.Formula, links) Then
            If result Is Nothing Then
                Set result = cell
            Else
                Set result = Union(result, cell)
            End If
        End If
    Next

    Set AllInternallyLinkedCells = result

End Function

Private Function AllExternallyLinkedCells(testRange As Range) As Range

    Dim result As Range, cell As Range
    Dim rawLinks As Variant
    Dim adjLinks() As String
    Dim fileName As String
    Dim wb As Workbook
    Dim i As Long

    'Acquire all the links
    rawLinks = ThisWorkbook.LinkSources(xlExcelLinks)
    ReDim adjLinks(1 To UBound(rawLinks) * 2)
    For i = 1 To UBound(rawLinks)
        fileName = Right(rawLinks(i), Len(rawLinks(i)) - InStrRev(rawLinks(i), "\"))
        Set wb = Nothing: On Error Resume Next
        Set wb = Workbooks(fileName): On Error GoTo 0
        adjLinks(i) = IIf(wb Is Nothing, rawLinks(i), fileName)
        adjLinks(i + 1) = Replace(adjLinks(i), fileName, "[" & fileName & "]")
        Debug.Print "External Link"; i; adjLinks(i + 1)
    Next

    For Each cell In testRange.SpecialCells(xlCellTypeFormulas)
        If Exists(cell.Formula, adjLinks) Then
            If result Is Nothing Then
                Set result = cell
            Else
                Set result = Union(result, cell)
            End If
        End If
    Next

    Set AllExternallyLinkedCells = result

End Function

Private Function Exists(item As String, arr As Variant) As Boolean
    Dim i As Long

    For i = LBound(arr) To UBound(arr)
        If InStr(item, arr(i)) > 0 Then
            Exists = True
            Exit Function
        End If
    Next
End Function

Sub RunMe（）
将extLinkCells设置为范围
将intLinkCells设置为范围
暗淡的公式化单元格范围
作为范围的Dim numberCells
暗淡单元格作为范围
Set numberCells=Sheet1.UsedRange.SpecialCells（xlCellTypeConstants）
设置extLinkCells=AllExternallyLinkedCells（Sheet1.UsedRange）
设置intLinkCells=AllIntnallyLinkedCells（表1.UsedRange）
'拾取剩余的非链接单元格（即必须是公式）
对于表1.UsedRange.SpecialCells（xlCellTypeFormulas）中的每个单元格
如果Intersect（单元格，extLinkCells）为空，Intersect（单元格，intLinkCells）为空，则
如果公式化细胞什么都不是，那么
设置公式单元格=单元格
其他的
设置公式化单元格=联合（公式化单元格，单元格）
如果结束
如果结束
下一个
numberCells.Font.Color=vbBlue
formulaCells.Font.Color=vbBlack
intLinkCells.Font.Color=vbGreen
extLinkCells.Font.Color=vbRed
端接头
专用函数所有内部链接单元（testRange作为范围）作为范围
变暗结果作为范围，单元格作为范围
Dim links（）作为字符串
将文件名设置为字符串
将wb设置为工作簿
将ws设置为工作表
名称为Dim nm
我想我会坚持多久
设置wb=testRange.Parent.Parent
'获取除此之外的所有图纸名称
i=1
对于wb.Sheets中的每个ws
如果是ws.Name testRange.sheet.Name，则
重拨保留链接（1到i）
链接（i）=ws.Name
调试。打印“内部链接”；我链接（一）
i=i+1
如果结束
下一个
'获取所有未引用此工作表的名称
对于wb.名称中的每个nm
如果是nm.referestorange.Worksheet.Name testRange.Worksheet.Name，则
重拨保留链接（1到i）
链接（i）=nm.Name
调试。打印“内部链接”；我链接（i）；“的”；nm.referestorange.Worksheet.Name
i=i+1
如果结束
下一个
'测试单元格公式是否与我们的列表匹配
对于testRange.SpecialCells（xlCellTypeFormulas）中的每个单元格
如果存在（cell.Formula、links），则
如果结果是什么，那么
设置结果=单元格
其他的
设置结果=并集（结果，单元格）
如果结束
如果结束
下一个
设置AllInternallyLinkedCells=结果
端函数
私有函数AllExternallyLinkedCells（testRange作为Range）作为Range
变暗结果作为范围，单元格作为范围
作为变体的链接
Dim adjLinks（）作为字符串
将文件名设置为字符串
将wb设置为工作簿
我想我会坚持多久
获取所有链接
rawLinks=此工作簿.LinkSources（xlExcelLinks）
ReDim adjLinks（1到UBound（rawLinks）*2）
对于i=1到UBound（原始链接）
fileName=Right（rawLinks（i），Len（rawLinks（i））-InStrRev（rawLinks（i），“\”）
设置wb=Nothing:出错时继续下一步
设置wb=工作簿（文件名）：错误转到0
adjLinks（i）=IIf（wb为零，rawLinks（i），文件名）
adjLinks（i+1）=替换（adjLinks（i），文件名“[”&fileName&“]））
调试。打印“外部链接”；我调整链接（i+1）
下一个
对于testRange.SpecialCells（xlCellTypeFormulas）中的每个单元格
如果存在（cell.Formula、adjLinks），则
如果结果是什么，那么
设置结果=单元格
其他的
设置结果=并集（结果，单元格）
如果结束
如果结束
下一个
设置AllExternallyLinkedCells=result
端函数
私有函数以布尔形式存在（项作为字符串，arr作为变量）
我想我会坚持多久
对于i=LBound（arr）到UBound（arr）
如果仪表（项目，arr（i））>0，则
存在=真
退出功能
如果结束
下一个
端函数

@antd，你通过了吗？