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

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

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

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

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

之前

这基本上就是我想要的。

之后

解决方法

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

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

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

,

使用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

,

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

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,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,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