根据另一个单元格中的值更改单元格中的字体颜色

Question

我想根据另一个单元格中的值更改单元格中某些文本的颜色。 我曾尝试使用条件格式，但它不起作用，因为我只想更改单元格中特定单词的颜色。 我也搜索了一些 VBA 代码，但仍然找不到合适的代码。 是否有任何 VBA 代码可以启用此功能？

如下例所示（见图），我只想突出显示与 G 列中的日期匹配的 B 列和 C 中的日期。日期应该保持不变。

有关信息，B 列和 C 中的值被格式化为文本，G 中的值被格式化为日期。

前

这基本上是我所希望的。

后

Answer 1

我已根据您在评论中的要求适当地修改了代码。

Sub Change_Text_Color()

Dim Find_Text, Cell, Cell_in_Col_G, LastCell_inColG As Range
Dim StartChar, CharLen, LastUsedRow_inRange, LastUsedRow_inColB, _
LastUsedRow_inColC As Integer

LastUsedRow_inColB = Sheet1.Cells(Rows.count, "B").End(xlUp).Row
LastUsedRow_inColC = Sheet1.Cells(Rows.count, "C").End(xlUp).Row
LastUsedRow_inRange = Application.WorksheetFunction. _
Max(LastUsedRow_inColB, LastUsedRow_inColC)

Set LastCell_inColG = Sheet1.Cells(Rows.count, "G").End(xlUp)

    For Each Cell In Range(Sheet1.Cells(2, 2), Cells(LastUsedRow_inRange, 3))
        
        For Each Cell_in_Col_G In Range(Sheet1.Cells(2, 7), LastCell_inColG)
            
            CharLen = Len(Cell_in_Col_G.Text)  
            Set Find_Text = Cell.Find(what:=Cell_in_Col_G.Text)
        
            If Not Find_Text Is Nothing Then
                StartChar = InStr(Cell.Value, Cell_in_Col_G.Text)        
                With Cell.Characters(StartChar, CharLen)
                    .Font.Color = RGB(0, 255, 0)
                End With                
            End If
        Next
    Next
End Sub

请让我知道您对此的反馈。

Answer 2

使用Characters ：

With Range("a1")
.Characters(Start:=1, Length:=4).Font.Color=0
.Characters(Start:=5, Length:=10.Font.Color=255
End With

将前四个字母涂成黑色，接下来的十个字母涂成红色。

参考：

• https://docs.microsoft.com/en-us/office/vba/api/excel.characters

Answer 3

我发现过滤在这些情况下效果很好。 假设您的工作表格式与示例工作表中的格式相同，请尝试以下代码：

Sub MarkDatesInCells()

    Dim oWS As Worksheet: Set oWS = ThisWorkbook.Worksheets("Sheet3")        '<- Change to the sheet name
    Dim iLRToHighlight As Long, iStartChar As Long, iC As Long, iLR As Long
    Dim oHighlightRng As Range, oUpdateRng As Range, oRng As Range
    Dim sColName As String
    
    ' Turn off updating
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    With oWS
        
        ' Clear autofilter if exists
        If .AutoFilterMode Then .AutoFilterMode = False
        
        ' Loop through all values specified in column G
        iLRToHighlight = .Range("G" & .Rows.Count).End(xlUp).Row
        For Each oHighlightRng In .Range("G2:G" & iLRToHighlight)
        
            ' Loop through column B and C
            For iC = 2 To 3
            
                ' Set autofilter based on the value in column G
                .UsedRange.AutoFilter iC, "=*" & oHighlightRng.Value
                
                ' Loop through all visible rows
                iLR = .Cells(.Rows.Count, iC).End(xlUp).Row
                If iLR > 1 Then
                
                    sColName = Left(Replace(.Cells(1, iC).Address, "$", ""), 1)
                    
                    Set oUpdateRng = .Range(sColName & "2:" & sColName & iLR).SpecialCells(xlCellTypeVisible)
                    
                    ' Update each cell text
                    For Each oRng In oUpdateRng
                        
                        iStartChar = InStr(1, oRng.Value, "- ", vbTextCompare) + 2
                        oRng.Characters(Start:=iStartChar, Length:=Len(oHighlightRng.Value)).Font.Color = 255
                    
                    Next
                    
                End If
                
                .AutoFilterMode = False
        
            Next
            
        Next
        
    End With
    
    ' Turn on updating
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

编辑

根据您对具有连接到数据库的表的工作表的此解决方案的要求，请尝试以下代码。 我没有可以测试以下代码的数据库，因此您可能需要对其进行一些修改才能使其正确（即突出显示的文本）

Sub MarkDatesInCellsInATable()

    Dim oWS As Worksheet: Set oWS = ThisWorkbook.Worksheets("Sheet4")        '<- Change to the sheet name
    Dim iLRToHighlight As Long, iStartChar As Long, iC As Long, iLR As Long
    Dim oHighlightRng As Range, oUpdateRng As Range, oRng As Range
    Dim sColName As String
    Dim oTable As ListObject: Set oTable = oWS.ListObjects("Table_ExceptionDetails.accdb")  '<- Change to the table name
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    With oWS
        
        ' Reset autofilter
        oTable.Range.AutoFilter
        
        ' Loop through all values specified in column G
        iLRToHighlight = .Range("G" & .Rows.Count).End(xlUp).Row
        For Each oHighlightRng In .Range("G2:G" & iLRToHighlight)
        
            ' Loop through column B and C
            For iC = 2 To 3
            
                ' Set autofilter based on the value in column G
                oTable.Range.AutoFilter iC, "=*" & oHighlightRng.Value & "*"
                
                ' Loop through all visible rows
                iLR = .Cells(.Rows.Count, iC).End(xlUp).Row
                If iLR > 1 Then
                
                    sColName = Left(Replace(.Cells(1, iC).Address, "$", ""), 1)
                    
                    Set oUpdateRng = .Range(sColName & "2:" & sColName & iLR).SpecialCells(xlCellTypeVisible)
                    
                    ' Update each cell text
                    For Each oRng In oUpdateRng
                        
                        iStartChar = InStr(1, oRng.Value, "- ", vbTextCompare) + 2
                        oRng.Characters(Start:=iStartChar, Length:=Len(oHighlightRng.Value)).Font.Color = 255
                    
                    Next
                    
                End If
                
                oTable.Range.AutoFilter
        
            Next
            
        Next
        
    End With
    
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub