对我来说，链接的单元格很难找到……但它们确实如此。
您不能只搜索[]，因为手动输入的链接可能会将它们排除在外，而该链接仍然可以使用。您不能只搜索文件名，因为两个同名文件可能存在于不同的文件夹中。您不能只搜索文件路径或\，因为如果链接的工作簿在同一个 Excel 应用程序中打开，则链接中会省略文件路径。
内部链接会带来类似的问题。例如，您不能依赖搜索!，因为链接可能是Name。
前段时间，我必须识别内部和外部链接的单元格，因此我编写了一些粗略且现成的代码来执行此操作。这些函数包含在下面的示例中，但我毫不怀疑会有例外（例如，任何包含与 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