return "1" IF a word in cell is with red font

[ferrigeu]

follow-up/change from question i posted under "VBA to return "1" if a word in cell is red".


i have a code (below) that is taking search criteria(s) via an Input box to find and change font to red for all words that match any of the search items
this words great
i want to change the xls so that a new vba will enter a "1" in e.g. d12 if either G12 or H12 have a red font item
once this is done, then trim the table to only show the items with a "1" in column d
@DanteAmor: if you read this - i can not download anything onto this pc. therefore i can not use the XL2BB functionality. screenshot of the table below

Sub HighlightStrings()
'Updateby Extendoffice

'sort the data
Call sorting

'change font back to black
ActiveSheet.Range("g12:h22500").Select
Range("g12:h22500").Font.ColorIndex = 1

'set parameters
Dim Rng As Range
Dim cFnd As String
Dim xTmp As String
Dim x As Long
Dim m As Long
Dim y As Long
Dim xFNum As Integer
Dim xArrFnd As Variant
Dim xStr As String
cFnd = InputBox("Please enter your Search Criteria(s), separate them by comma:")
If Len(cFnd) < 1 Then Exit Sub

'not case sensitive
xArrFnd = Split(UCase(cFnd), ",")


'case sensitive
'xArrFnd = Split(cFnd, ",")


'define the range of the data
ActiveSheet.Range("g12:h22500").Select

For Each Rng In selection
With Rng
For xFNum = 0 To UBound(xArrFnd)
xStr = xArrFnd(xFNum)
y = Len(xStr)
m = UBound(Split(UCase(Rng.Value), UCase(xStr)))


'case sensitive
'm = UBound(Split(Rng.Value, xStr))


If m > 0 Then
xTmp = ""
For x = 0 To m - 1



xTmp = xTmp & Split(UCase(Rng.Value), UCase(xStr))(x)

'case sensitive
'xTmp = xTmp & Split(UCase(Rng.Value), UCase(xStr))(x)


.Characters(Start:=Len(xTmp) + 1, Length:=y).Font.ColorIndex = 3
xTmp = xTmp & xStr
Next
End If
Next xFNum
End With
Next Rng

Application.ScreenUpdating = True

'cursor goes back
Range("a1").Select




End Sub
Sub sorting()
'
' sorting Macro
'

'
    Range("g12:h22500").Select
    ActiveWorkbook.Worksheets("Almanac").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Almanac").Sort.SortFields.Add Key:=Range( _
        "G12:G22500"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("Almanac").Sort.SortFields.Add Key:=Range( _
        "H12:H22500"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Almanac").Sort
        .SetRange Range("G11:H5257")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
   

'Call Return_1_2

End Sub

 

[ChrisFoster]

Give this a go.

Sub HighlightStringsAndMark()
'Update by Extendoffice

'sort the data
Call sorting

'change font back to black
ActiveSheet.Range("g12:h22500").Select
Range("g12:h22500").Font.ColorIndex = 1

'set parameters
Dim Rng As Range
Dim cFnd As String
Dim xTmp As String
Dim x As Long
Dim m As Long
Dim y As Long
Dim xFNum As Integer
Dim xArrFnd As Variant
Dim xStr As String
Dim cell As Range
Dim ws As Worksheet
Dim lastRow As Long

cFnd = InputBox("Please enter your Search Criteria(s), separate them by comma:")
If Len(cFnd) < 1 Then Exit Sub

'not case sensitive
xArrFnd = Split(UCase(cFnd), ",")

'case sensitive
'xArrFnd = Split(cFnd, ",")

'store the worksheet object in a variable
Set ws = ThisWorkbook.Worksheets("Almanac")

'determine the last row in column D
lastRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row

'clear existing values in column D
ws.Range("D12:D" & lastRow).ClearContents

'define the range of the data
ws.Range("G12:H" & lastRow).Select

For Each Rng In Selection
    With Rng
        For xFNum = 0 To UBound(xArrFnd)
            xStr = xArrFnd(xFNum)
            y = Len(xStr)
            m = UBound(Split(UCase(Rng.Value), UCase(xStr)))

            'case sensitive
            'm = UBound(Split(Rng.Value, xStr))

            If m > 0 Then
                xTmp = ""
                For x = 0 To m - 1
                    xTmp = xTmp & Split(UCase(Rng.Value), UCase(xStr))(x)

                    'case sensitive
                    'xTmp = xTmp & Split(UCase(Rng.Value), UCase(xStr))(x)

                    .Characters(Start:=Len(xTmp) + 1, Length:=y).Font.ColorIndex = 3
                    xTmp = xTmp & xStr
                Next
                'if the font color is red, mark the corresponding cell in column D with a "1"
                If .Font.ColorIndex = 3 Then
                    Set cell = .Offset(0, 2)
                    If cell.Value <> "" Then
                        cell.Value = cell.Value & ",1"
                    Else
                        cell.Value = "1"
                    End If
                End If
            End If
        Next xFNum
    End With
Next Rng

'convert comma-separated values in column D to a binary format
ws.Range("D12:D" & lastRow).Replace What:="1", Replacement:="1", LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
ws.Range("D12:D" & lastRow).Replace What:=",", Replacement:="1", LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
ws.Range("D12:D" & lastRow).Replace What:="", Replacement:="0",

 

[ferrigeu]

hi Chris
sorry for the delay in responding
i tried your suggestion but
1) the search items no longer change to RED
2) column D remains blank and
3) there it does not sort
i tried to fiddle to see if i can figure out where the issue(s) is/are, but i came up blank...
thoughts?

 

[ferrigeu]

hi Chris
did you have time to look at my response please?
thank you