如何用VBA根据Excel单元格格式修改字体颜色（超链接场景）

我有一段Excel VBA代码，功能是找到文本匹配项后，将单元格链接到工作簿内的其他单元格。代码运行正常，但添加超链接时会覆盖原有单元格颜色设置，所有单元格变成蓝色并添加下划线，导致部分底色下的文本难以辨认。

我的需求是：在循环中检查当前单元格的格式代码，当CELL("format", B2)返回P3、F1、F2、F3、F4、F5或F6时，将单元格文本颜色改为白色后再进入下一个循环。

原始代码 #

Sub mySheet()
    
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    Dim dws As Worksheet: Set dws = wb.Sheets("mySheet")
    Dim drg As Range: Set drg = dws.Range("B2:B20")
    drg.ClearHyperlinks
    drg.Font.Underline = False
    
    Dim sws As Worksheet, scell As Range, dcell As Range
    Dim dValue As Variant, IsValueValid As Boolean

    For Each dcell In drg.Cells
        dValue = dcell.Value
        IsValueValid = False
        If Not IsError(dValue) Then
            If Len(dValue) > 0 Then IsValueValid = True
        End If
        If IsValueValid Then
            For Each sws In wb.Worksheets
                If sws.Name <> dws.Name Then
                    Set scell = sws.UsedRange.Find(What:=dValue, _
                        LookIn:=xlValues, LookAt:=xlWhole)
                    If Not scell Is Nothing Then
                        dws.Hyperlinks.Add _
                            Anchor:=dcell, _
                            Address:="", _
                            SubAddress:="'" & sws.Name & "'!" & scell.Address, _
                            TextToDisplay:=CStr(dValue)
                        Exit For
                    End If
                End If
            Next sws
        End If
        
        ' %%insert custom format code here?? %%% '

    Next dcell

    MsgBox "Hyperlinks generated.", vbInformation
    
End Sub

遇到的问题 #

我找不到VBA中对应CELL("format", B2)的方法，无法着手修改。作为替代方案，我尝试检查单元格颜色，当颜色为特定值时修改文本颜色，但代码插入后并未生效，可能是放置位置错误？

尝试修改后的代码：

Sub mySheet()
    
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    Dim dws As Worksheet: Set dws = wb.Sheets("mySheet")
    Dim drg As Range: Set drg = dws.Range("B2:B20")
    drg.ClearHyperlinks
    drg.Font.Underline = False
    
    Dim sws As Worksheet, scell As Range, dcell As Range
    Dim dValue As Variant, IsValueValid As Boolean

    For Each dcell In drg.Cells
        dValue = dcell.Value
        IsValueValid = False
        If Not IsError(dValue) Then
            If Len(dValue) > 0 Then IsValueValid = True
        End If
        If IsValueValid Then
            For Each sws In wb.Worksheets
                If sws.Name <> dws.Name Then
                    Set scell = sws.UsedRange.Find(What:=dValue, _
                        LookIn:=xlValues, LookAt:=xlWhole)
                    If Not scell Is Nothing Then
                        dws.Hyperlinks.Add _
                            Anchor:=dcell, _
                            Address:="", _
                            SubAddress:="'" & sws.Name & "'!" & scell.Address, _
                            TextToDisplay:=CStr(dValue)
                        Exit For
                    End If
                End If
            Next sws
        End If
        
       If dcell.Interior.Color = RGB(155, 0, 255) _
       Then Set dcell.Font.Color = RGB(255, 255, 255)

    Next dcell

    MsgBox "Hyperlinks generated.", vbInformation
    
End Sub

解决方案 #

关键修正点 #

1. 获取CELL("format")的VBA方法：使用Application.WorksheetFunction.Cell("format", dcell)可以直接获取对应Excel函数的格式代码结果。
2. 修正颜色赋值错误：原尝试代码中Set dcell.Font.Color是错误写法，应直接赋值dcell.Font.Color = RGB(255,255,255)，无需Set。
3. 调整代码位置：格式/颜色判断必须放在超链接添加之后，确保修改的是超链接生效后的字体格式。

修改后的完整代码 #

Sub mySheet()
    
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    Dim dws As Worksheet: Set dws = wb.Sheets("mySheet")
    Dim drg As Range: Set drg = dws.Range("B2:B20")
    drg.ClearHyperlinks
    drg.Font.Underline = False
    
    Dim sws As Worksheet, scell As Range, dcell As Range
    Dim dValue As Variant, IsValueValid As Boolean
    Dim cellFormat As String
    ' 定义需要判断的格式代码集合
    Dim targetFormats As Variant: targetFormats = Array("P3", "F1", "F2", "F3", "F4", "F5", "F6")

    For Each dcell In drg.Cells
        dValue = dcell.Value
        IsValueValid = False
        If Not IsError(dValue) Then
            If Len(dValue) > 0 Then IsValueValid = True
        End If
        If IsValueValid Then
            For Each sws In wb.Worksheets
                If sws.Name <> dws.Name Then
                    Set scell = sws.UsedRange.Find(What:=dValue, _
                        LookIn:=xlValues, LookAt:=xlWhole)
                    If Not scell Is Nothing Then
                        dws.Hyperlinks.Add _
                            Anchor:=dcell, _
                            Address:="", _
                            SubAddress:="'" & sws.Name & "'!" & scell.Address, _
                            TextToDisplay:=CStr(dValue)
                        Exit For
                    End If
                End If
            Next sws
        End If
        
        ' 获取单元格格式代码并判断，符合条件则设置白色字体
        cellFormat = Application.WorksheetFunction.Cell("format", dcell)
        If IsNumeric(Application.Match(cellFormat, targetFormats, 0)) Then
            dcell.Font.Color = RGB(255, 255, 255)
            ' 可选：如果需要去掉超链接的下划线，取消下面一行注释
            ' dcell.Font.Underline = False
        End If
        
        ' 若仍需使用底色判断方案，替换上面的格式判断代码为以下内容：
        ' If dcell.Interior.Color = RGB(155, 0, 255) Then
        '     dcell.Font.Color = RGB(255, 255, 255)
        '     ' 可选：去掉下划线
        '     ' dcell.Font.Underline = False
        ' End If

    Next dcell

    MsgBox "Hyperlinks generated.", vbInformation
    
End Sub

代码说明 #

• 通过targetFormats数组统一管理需要判断的格式代码，便于后续维护。
• 使用Application.Match快速检测当前单元格格式是否在目标列表中，比多个Or判断更简洁高效。
• 保留了两种方案（格式代码判断/底色判断），可根据实际需求切换。

内容的提问来源于stack exchange，提问作者Rhedogian