在其他工作簿中的同一工作簿与参考文献中确定参考

Question

我想根据下面的参数使Excel VBA代码对字体进行着色：

• 蓝色：硬编码数字
• 黑色：公式（ex。Sum，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

Answer 1

您可以尝试以下方法：

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

Answer 2

在我看来很难找到链接的细胞……但是它们确实是。

您不能仅仅搜索[]，因为手动键入的链接可以将它们排除在外，并且该链接仍然可以正常工作。您不能仅搜索文件名，因为两个文件夹中可能存在两个具有相同名称的文件。您不能仅搜索文件路径或，因为如果链接的工作簿在同一Excel应用程序中打开，则从链接中省略了filepath。

内部链接提出了类似的问题。您不能依靠搜索!，因为该链接可能是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