Блог

Я хотел бы изменить цвет определенного текста в ячейках на основе значений в других ячейках. Я пытался использовать условное форматирование, но это не сработало, поскольку я хотел изменить цвет только определенных слов в ячейках. Я также погуглил несколько кодов VBA, но все еще не смог найти правильный. Существует ли какой-либо код VBA для включения этого?

Как показано в примере ниже (см. Изображение), я хочу выделить ТОЛЬКО даты в столбцах B и C, которые соответствуют датам в столбце G. День должен остаться прежним.

Для информации значения в столбцах B и C отформатированы как текст, а значения в G отформатированы как дата.

Перед

и это в основном то, чего я желаю.

После

Я соответствующим образом изменил код в соответствии с вашим требованием в комментарии.

 Sub Chan&e_Text_Color()

Dim Find_Text, Cell, Cell_in_Col_G, LastCell_inColG As Ran&e
Dim StartChar, CharLen, LastUsedRow_inRan&e, LastUsedRow_inColB, _
LastUsedRow_inColC As Inte&er

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

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

    For Each Cell In Ran&e(Sheet1.Cells(2, 2), Cells(LastUsedRow_inRan&e, 3))
        
        For Each Cell_in_Col_G In Ran&e(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 Nothin& 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 Ran&e("a1")
.Characters(Start:=1, Len&th:=4).Font.Color=0
.Characters(Start:=5, Len&th:=10.Font.Color=255
End With
  

покрасьте первые четыре буквы в черный цвет, а следующие десять — в красный.

Ссылка:

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

Я считаю, что фильтрация хорошо работает в этих сценариях. Предполагая, что формат вашего листа такой же, как в ваших примерах листов, попробуйте приведенный ниже код:

 Sub MarkDatesInCells()

    Dim oWS As Worksheet: Set oWS = ThisWorkbook.Worksheets("Sheet3")        '<- Chan&e to the sheet name
    Dim iLRToHi&hli&ht As Lon&, iStartChar As Lon&, iC As Lon&, iLR As Lon&
    Dim oHi&hli&htRn& As Ran&e, oUpdateRn& As Ran&e, oRn& As Ran&e
    Dim sColName As Strin&
    
    ' Turn off updatin&
    Application.ScreenUpdatin& = False
    Application.EnableEvents = False
    
    With oWS
        
        ' Clear autofilter if exists
        If .AutoFilterMode Then .AutoFilterMode = False
        
        ' Loop throu&h all values specified in column G
        iLRToHi&hli&ht = .Ran&e("G" amp; .Rows.Count).End(xlUp).Row
        For Each oHi&hli&htRn& In .Ran&e("G2:G" amp; iLRToHi&hli&ht)
        
            ' Loop throu&h column B and C
            For iC = 2 To 3
            
                ' Set autofilter based on the value in column G
                .UsedRan&e.AutoFilter iC, "=*" amp; oHi&hli&htRn&.Value
                
                ' Loop throu&h all visible rows
                iLR = .Cells(.Rows.Count, iC).End(xlUp).Row
                If iLR &&t; 1 Then
                
                    sColName = Left(Replace(.Cells(1, iC).Address, "$", ""), 1)
                    
                    Set oUpdateRn& = .Ran&e(sColName amp; "2:" amp; sColName amp; iLR).SpecialCells(xlCellTypeVisible)
                    
                    ' Update each cell text
                    For Each oRn& In oUpdateRn&
                        
                        iStartChar = InStr(1, oRn&.Value, "- ", vbTextCompare)   2
                        oRn&.Characters(Start:=iStartChar, Len&th:=Len(oHi&hli&htRn&.Value)).Font.Color = 255
                    
                    Next
                    
                End If
                
                .AutoFilterMode = False
        
            Next
            
        Next
        
    End With
    
    ' Turn on updatin&
    Application.ScreenUpdatin& = True
    Application.EnableEvents = True
End Sub
  

Редактировать

Исходя из вашего требования иметь это решение для листа с таблицей, подключенной к базе данных, попробуйте приведенный ниже код. У меня нет базы данных, на которой я мог бы протестировать приведенный ниже код, поэтому вам, возможно, придется немного повозиться с ним, чтобы получить его правильно (т. Е. Текст, который выделяется)

 Sub MarkDatesInCellsInATable()

    Dim oWS As Worksheet: Set oWS = ThisWorkbook.Worksheets("Sheet4")        '<- Chan&e to the sheet name
    Dim iLRToHi&hli&ht As Lon&, iStartChar As Lon&, iC As Lon&, iLR As Lon&
    Dim oHi&hli&htRn& As Ran&e, oUpdateRn& As Ran&e, oRn& As Ran&e
    Dim sColName As Strin&
    Dim oTable As ListObject: Set oTable = oWS.ListObjects("Table_ExceptionDetails.accdb")  '<- Chan&e to the table name
    
    Application.ScreenUpdatin& = False
    Application.EnableEvents = False
    
    With oWS
        
        ' Reset autofilter
        oTable.Ran&e.AutoFilter
        
        ' Loop throu&h all values specified in column G
        iLRToHi&hli&ht = .Ran&e("G" amp; .Rows.Count).End(xlUp).Row
        For Each oHi&hli&htRn& In .Ran&e("G2:G" amp; iLRToHi&hli&ht)
        
            ' Loop throu&h column B and C
            For iC = 2 To 3
            
                ' Set autofilter based on the value in column G
                oTable.Ran&e.AutoFilter iC, "=*" amp; oHi&hli&htRn&.Value amp; "*"
                
                ' Loop throu&h all visible rows
                iLR = .Cells(.Rows.Count, iC).End(xlUp).Row
                If iLR &&t; 1 Then
                
                    sColName = Left(Replace(.Cells(1, iC).Address, "$", ""), 1)
                    
                    Set oUpdateRn& = .Ran&e(sColName amp; "2:" amp; sColName amp; iLR).SpecialCells(xlCellTypeVisible)
                    
                    ' Update each cell text
                    For Each oRn& In oUpdateRn&
                        
                        iStartChar = InStr(1, oRn&.Value, "- ", vbTextCompare)   2
                        oRn&.Characters(Start:=iStartChar, Len&th:=Len(oHi&hli&htRn&.Value)).Font.Color = 255
                    
                    Next
                    
                End If
                
                oTable.Ran&e.AutoFilter
        
            Next
            
        Next
        
    End With
    
    Application.ScreenUpdatin& = True
    Application.EnableEvents = True
End Sub