Macro Loop Next Row-CodePudding

I have this macro that finds the string in Column C and highlights it in red if found in Column G's text. This is row sensitive. Right now I have a big code with an entry per row, but it would be much better to use a loop for each row until the last one. Any idea?

It looks like this (Only rows 2 and 3 in the example):

Sub Macro1()

Set ThisWB = ActiveWorkbook
Set ThisWS = ActiveSheet

Col1 = 3
Col2 = 7
Col1_rowSTART = 2
Col2_rowSTART = 2
Col1_rowEND = 2
Col2_rowEND = 2

For i = Col1_rowSTART To Col1_rowEND
    strTest = CStr(ThisWS.Cells(i, Col1))
    strLen = Len(strTest)
    For y = Col2_rowSTART To Col2_rowEND
        If InStr(CStr(ThisWS.Cells(y, Col2)), strTest) > 0 Then
            ThisWS.Cells(y, Col2).Characters(InStr(ThisWS.Cells(y, Col2), strTest), strLen).Font.Color = vbRed
            
        End If
    Next y
Next i

Set ThisWB = ActiveWorkbook
Set ThisWS = ActiveSheet
Col1 = 3 
Col2 = 7 
Col1_rowSTART = 3
Col2_rowSTART = 3
Col1_rowEND = 3
Col2_rowEND = 3
    
For i = Col1_rowSTART To Col1_rowEND
    strTest = CStr(ThisWS.Cells(i, Col1))
    strLen = Len(strTest)
    For y = Col2_rowSTART To Col2_rowEND
        If InStr(CStr(ThisWS.Cells(y, Col2)), strTest) > 0 Then
            ThisWS.Cells(y, Col2).Characters(InStr(ThisWS.Cells(y, Col2), strTest), strLen).Font.Color = vbRed
                
        End If
    Next y
Next i

End Sub

I got something that did not work, because it would color all the stings in column C if found in Column G (not row sensitive). I forgot to save the code.

I also tried this, but it colored all text in Column G instead of the String:

Sub Macro3()

Dim aRow As Range
For Each aRow In Selection.Rows.EntireRow

Set ThisWB = ActiveWorkbook
Set ThisWS = ActiveSheet
Col1 = 3 'Words Col C
Col2 = 7 'Comments Col G

Col1_rowSTART = 2
Col1_rowEND = 500

For i = Col1_rowSTART To Col1_rowEND
    strTest = CStr(ThisWS.Cells(i, Col1))
    strLen = Len(strTest)

For y = Col1_rowSTART To Col1_rowEND
        If InStr(CStr(ThisWS.Cells(y, Col2)), strTest) > 0 Then
            ThisWS.Cells(y, Col2).Characters(InStr(ThisWS.Cells(y, Col2), strTest), strLen).Font.Color = vbRed
                
        End If
    Next y
Next i

Next aRow

End Sub

CodePudding user response：

This code works on the workbook containing the code on the sheet with the tab name Sheet1 (ThisWorkbook.Worksheets("Sheet1")).

It will work from row 2 until the last row containing data in column C.

Option Explicit

    Sub Test()
    
        With ThisWorkbook.Worksheets("Sheet1")
        
            Dim LastRow As Long
            LastRow = .Cells(Rows.Count, 3).End(xlUp).Row 'Last row in column 3.
            
            Dim Cell As Range
            For Each Cell In .Range(.Cells(2, 3), .Cells(LastRow, 3)) 'Each cell between row 2 and last row.
                AddColour Cell, Cell.Offset(, 4) 'Pass the cell and the cell four columns across to the AddColour procedure.
            Next Cell
        
        End With
    
    End Sub
    
    Public Sub AddColour(Source As Range, Target As Range)
    
        Dim PosInString As Long
        PosInString = InStr(Target, Source) 'Will be >0 if Source is within Target.
        
        If PosInString > 0 Then
            Target.Characters(Start:=PosInString, Length:=Len(Source)).Font.Color = vbRed
        End If
    
    End Sub

It is case-sensitive so "Red" does not equal "red".