Question

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

蓝色：硬编码的数字
黑色：公式（例如总和，vlookup，平均值等）
绿色：从同一档案中的其他工作表链接的数字
红色：从外部文件中的其他工作表链接的数字

我已经编写了下面的代码，但它没有区分同一文件中的另一个单元格/表格与外部文件中的引用的引用。任何帮助都可以很好地完成最后一步。

由于

undefined

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应用程序中打开，则链接中将省略文件路径。

内部链接也存在类似问题。您不能依赖于搜索!，因为该链接可能是Name，例如。

前段时间，我不得不识别内部和外部链接的单元格，因此我编写了一些粗略且准备好的代码来完成它。这些功能包含在下面的示例中，但我毫无疑问会有例外（例如，任何包含与Name名称相同的字符串的公式都将无法通过测试。）< / p>

我将这些功能保存为单独的例程，因为它们可能对其他用户有用，但它确实使您的项目代码效率低下。可能会证明你可以解决这个问题。

您注意我刚刚使用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

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

2 个答案: