Highlight specific text in range based on value of three cells

Status
Not open for further replies.
M

Mylarbi

New Member
Joined
Feb 9, 2020
Messages
48
Office Version
  1. 365
Platform
  1. Windows
  2. MacOS
Hi all, I will appreciate help with this please.
I have the following vba code working where for any text put in cell M2, it is searched in the range M5:M55 and anywhere the text is found, it is highlighted.
VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
 
    If Target.Count > 1 Then Exit Sub
    SelectAndChange (Target)
 
End Sub
 
Private Sub SelectAndChange(strValue As String)
 
    Dim rngCell     As Range
    Dim rngRange    As Range
    Dim strLookFor  As String
    Dim arrChar     As Variant
    Dim lngCounter  As Long
 
    If strValue = vbNullString Then Exit Sub
    Application.EnableEvents = False
 
    Set rngRange = Range("M5:M555")
    rngRange.Font.Color = vbBlack
    strLookFor = Range("M2").Value
 
    For Each rngCell In rngRange
        For lngCounter = 1 To Len(rngCell) - Len(strLookFor) + 1
            If Mid(rngCell, lngCounter, Len(strLookFor)) = strLookFor Then
                rngCell.Characters(lngCounter, Len(strLookFor)).Font.Color = vbRed
            End If
        Next lngCounter
    Next rngCell
 
    Application.EnableEvents = True
 
End Sub
I need help to improve this where the search criteria, currently using cell M2, is expanded to include value of cells N2 and O2.
The search range should remain M5:M55
Thanks
 
Sort by date Sort by votes
Mylarbi said:
The private sub seems to be triggered unnecessarily when I am working on the sheet
Click to expand...
Only when you modify any of the cells in these ranges:

Range("M2:O2, M5:M" & Rows.Count)

Mylarbi said:
Please is it possible to turn it into a standard macro
Click to expand...
Try this in a module:

VBA Code: 
Sub Highlight_specific_text()
  Dim rngLooks    As Range, f As Range, r As Range
  Dim strLookFor  As String, cell As String
  Dim lngCounter  As Long
 
  Application.ScreenUpdating = False
  Set r = Range("M5", Range("M" & Rows.Count).End(3))
  r.Font.Color = vbBlack
 
  For Each rngLooks In Range("M2:O2")
    strLookFor = LCase(rngLooks.Value)
    Set f = r.Find(strLookFor, , xlValues, xlPart, , , False)
    If Not f Is Nothing Then
      cell = f.Address
      Do
        For lngCounter = 1 To Len(f) - Len(strLookFor) + 1
          If LCase(Mid(f, lngCounter, Len(strLookFor))) = strLookFor Then
            f.Characters(lngCounter, Len(strLookFor)).Font.Color = vbRed
            lngCounter = lngCounter + Len(strLookFor) - 1
          End If
        Next lngCounter
        Set f = r.FindNext(f)
      Loop While Not f Is Nothing And f.Address <> cell
    End If
  Next rngLooks
  Application.ScreenUpdating = True
End Sub

Note: You must remove the macro from the sheet events.
 
Upvote 0
Solution

Excel Facts

How to create a cell-sized chart?
Tiny charts, called Sparklines, were added to Excel 2010. Look for Sparklines on the Insert tab.
DanteAmor said:
Only when you modify any of the cells in these ranges:

Range("M2:O2, M5:M" & Rows.Count)


Try this in a module:

VBA Code: 
Sub Highlight_specific_text()
  Dim rngLooks    As Range, f As Range, r As Range
  Dim strLookFor  As String, cell As String
  Dim lngCounter  As Long
 
  Application.ScreenUpdating = False
  Set r = Range("M5", Range("M" & Rows.Count).End(3))
  r.Font.Color = vbBlack
 
  For Each rngLooks In Range("M2:O2")
    strLookFor = LCase(rngLooks.Value)
    Set f = r.Find(strLookFor, , xlValues, xlPart, , , False)
    If Not f Is Nothing Then
      cell = f.Address
      Do
        For lngCounter = 1 To Len(f) - Len(strLookFor) + 1
          If LCase(Mid(f, lngCounter, Len(strLookFor))) = strLookFor Then
            f.Characters(lngCounter, Len(strLookFor)).Font.Color = vbRed
            lngCounter = lngCounter + Len(strLookFor) - 1
          End If
        Next lngCounter
        Set f = r.FindNext(f)
      Loop While Not f Is Nothing And f.Address <> cell
    End If
  Next rngLooks
  Application.ScreenUpdating = True
End Sub

Note: You must remove the macro from the sheet events.
Click to expand...
Hi @DanteAmor , This works smoothly. With this, the persistent freezing I was experiencing while working on the sheet has now stopped. My sincere gratitude to you.
 
Upvote 0
Try the following:
If you change the data in M2 to O2, then check the entire range from M5 onwards.
If you only modify one line from the M5 range onwards, only that line will be revised.

VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
  Dim rng1 As Range, rng2 As Range
  Dim r As Range
  
  If Target.CountLarge > 1 Then Exit Sub
  Set r = Range("M5", Range("M" & Rows.Count).End(3))
  Set rng1 = Intersect(Target, Range("M2:O2"))
  Set rng2 = Intersect(Target, r)
  If Not rng1 Is Nothing Then
    SelectAndChange r
  ElseIf Not rng2 Is Nothing Then
    SelectAndChange Target
  End If
End Sub
 
Private Sub SelectAndChange(r As Range)
  Dim rngLooks    As Range, f As Range
  Dim strLookFor  As String, cell As String
  Dim lngCounter  As Long
  
  Application.ScreenUpdating = False
  r.Font.Color = vbBlack
  
  For Each rngLooks In Range("M2:O2")
    strLookFor = LCase(rngLooks.Value)
    Set f = r.Find(strLookFor, , xlValues, xlPart, , , False)
    If Not f Is Nothing Then
      cell = f.Address
      Do
        For lngCounter = 1 To Len(f) - Len(strLookFor) + 1
          If LCase(Mid(f, lngCounter, Len(strLookFor))) = strLookFor Then
            f.Characters(lngCounter, Len(strLookFor)).Font.Color = vbRed
            lngCounter = lngCounter + Len(strLookFor) - 1
          End If
        Next lngCounter
        Set f = r.FindNext(f)
      Loop While Not f Is Nothing And f.Address <> cell
    End If
  Next rngLooks
  Application.ScreenUpdating = True
End Sub

___________________________________________________________________________________
The following code works the same as the previous one, the difference is that if you modify more than one line in the range M5 onwards, all cells will be checked. That is, if you modify cells M7 to M26 (20 cells or more) at the same time, then all those cells will be checked.

VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
  Dim rng1 As Range, rng2 As Range
  Dim r As Range, c As Range
  
  Set r = Range("M5", Range("M" & Rows.Count).End(3))
  Set rng1 = Intersect(Target, Range("M2:O2"))
  Set rng2 = Intersect(Target, r)
  If Not rng1 Is Nothing Then
    SelectAndChange r
  ElseIf Not rng2 Is Nothing Then
    For Each c In rng2
      SelectAndChange c
    Next
  End If
End Sub
 
Private Sub SelectAndChange(r As Range)
  Dim rngLooks    As Range, f As Range
  Dim strLookFor  As String, cell As String
  Dim lngCounter  As Long
  
  Application.ScreenUpdating = False
  r.Font.Color = vbBlack
  
  For Each rngLooks In Range("M2:O2")
    strLookFor = LCase(rngLooks.Value)
    Set f = r.Find(strLookFor, , xlValues, xlPart, , , False)
    If Not f Is Nothing Then
      cell = f.Address
      Do
        For lngCounter = 1 To Len(f) - Len(strLookFor) + 1
          If LCase(Mid(f, lngCounter, Len(strLookFor))) = strLookFor Then
            f.Characters(lngCounter, Len(strLookFor)).Font.Color = vbRed
            lngCounter = lngCounter + Len(strLookFor) - 1
          End If
        Next lngCounter
        Set f = r.FindNext(f)
      Loop While Not f Is Nothing And f.Address <> cell
    End If
  Next rngLooks
  Application.ScreenUpdating = True
End Sub
 
Upvote 0
The
DanteAmor said:
Try the following:
If you change the data in M2 to O2, then check the entire range from M5 onwards.
If you only modify one line from the M5 range onwards, only that line will be revised.

VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
  Dim rng1 As Range, rng2 As Range
  Dim r As Range
 
  If Target.CountLarge > 1 Then Exit Sub
  Set r = Range("M5", Range("M" & Rows.Count).End(3))
  Set rng1 = Intersect(Target, Range("M2:O2"))
  Set rng2 = Intersect(Target, r)
  If Not rng1 Is Nothing Then
    SelectAndChange r
  ElseIf Not rng2 Is Nothing Then
    SelectAndChange Target
  End If
End Sub
 
Private Sub SelectAndChange(r As Range)
  Dim rngLooks    As Range, f As Range
  Dim strLookFor  As String, cell As String
  Dim lngCounter  As Long
 
  Application.ScreenUpdating = False
  r.Font.Color = vbBlack
 
  For Each rngLooks In Range("M2:O2")
    strLookFor = LCase(rngLooks.Value)
    Set f = r.Find(strLookFor, , xlValues, xlPart, , , False)
    If Not f Is Nothing Then
      cell = f.Address
      Do
        For lngCounter = 1 To Len(f) - Len(strLookFor) + 1
          If LCase(Mid(f, lngCounter, Len(strLookFor))) = strLookFor Then
            f.Characters(lngCounter, Len(strLookFor)).Font.Color = vbRed
            lngCounter = lngCounter + Len(strLookFor) - 1
          End If
        Next lngCounter
        Set f = r.FindNext(f)
      Loop While Not f Is Nothing And f.Address <> cell
    End If
  Next rngLooks
  Application.ScreenUpdating = True
End Sub

___________________________________________________________________________________
The following code works the same as the previous one, the difference is that if you modify more than one line in the range M5 onwards, all cells will be checked. That is, if you modify cells M7 to M26 (20 cells or more) at the same time, then all those cells will be checked.

VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
  Dim rng1 As Range, rng2 As Range
  Dim r As Range, c As Range
 
  Set r = Range("M5", Range("M" & Rows.Count).End(3))
  Set rng1 = Intersect(Target, Range("M2:O2"))
  Set rng2 = Intersect(Target, r)
  If Not rng1 Is Nothing Then
    SelectAndChange r
  ElseIf Not rng2 Is Nothing Then
    For Each c In rng2
      SelectAndChange c
    Next
  End If
End Sub
 
Private Sub SelectAndChange(r As Range)
  Dim rngLooks    As Range, f As Range
  Dim strLookFor  As String, cell As String
  Dim lngCounter  As Long
 
  Application.ScreenUpdating = False
  r.Font.Color = vbBlack
 
  For Each rngLooks In Range("M2:O2")
    strLookFor = LCase(rngLooks.Value)
    Set f = r.Find(strLookFor, , xlValues, xlPart, , , False)
    If Not f Is Nothing Then
      cell = f.Address
      Do
        For lngCounter = 1 To Len(f) - Len(strLookFor) + 1
          If LCase(Mid(f, lngCounter, Len(strLookFor))) = strLookFor Then
            f.Characters(lngCounter, Len(strLookFor)).Font.Color = vbRed
            lngCounter = lngCounter + Len(strLookFor) - 1
          End If
        Next lngCounter
        Set f = r.FindNext(f)
      Loop While Not f Is Nothing And f.Address <> cell
    End If
  Next rngLooks
  Application.ScreenUpdating = True
End Sub
Click to expand...
Yes, Keeping it private sub this way also works well, making it still a viable option. No more freezing. However I think the highlighting part has been affected while you were editing because,
1.now only the text from M2 is highlighted and
2. the red starts from the first character in the cell all the way to the target text.
 
Upvote 0
Mylarbi said:
1.now only the text from M2 is highlighted and
2. the red starts from the first character in the cell all the way to the target text.
Click to expand...
You could post your example here, because the code from post #13 works fine for me.
 
Upvote 0
First it works in a clean new workbook as in the first screenshot.
But when I apply the same code in the target workbook which has other macros and formatting, I get the error described earlier as seen in second screenshot.
#1
1636577683785.png


#2
1636576919387.png

It is when I edit a cell that
 
Upvote 0
Mylarbi said:
in the target workbook which has other macros and formatting
Click to expand...
You could stop or delete the other macros and just test the code that I sent you.
That way we rule out if the problem is my macro or the other macros.
If the problem is with the other macros, then we check them.
 
Upvote 0
Yes, deleting other macros stops the problem. I am not good at vba so what I have now is list like a scrapbook of codes. And not well commented yet.
VBA Code: 
Sub TRIMM()
    'trim text in column M
    Dim rng         As Range
    Set rng = Sheets("AXXX").Range("M5:M1000")
    rng.Value = Application.Trim(rng)
   
End Sub

Sub DELBRKS()
    'delete line breaks in text
    Set myRange = Application.Selection
    Set myRange = Application.InputBox("Select Range", "RemoveLineBreaks", myRange.Address, Type:=8)
    For Each myCell In myRange
        myCell.Value = Replace(myCell.Value, Chr(10), ", ")
    Next
    For Each myCell In myRange
        myCell.Value = WorksheetFunction.Trim(myCell)
    Next
   
End Sub

Sub KL33ALL()
    With Range("L2:Q2")
        Range("L2:Q2") = ""
    End With
    Dim lo          As ListObject
    'Set reference to the first Table on the sheet
    Set lo = ActiveSheet.ListObjects(1)
    'Clear All Filters for entire Table
    lo.AutoFilter.ShowAllData
    'Change text colour
    Application.ScreenUpdating = FALSE
    Set r = Range("M5", Range("M" & Rows.Count).End(3))
    r.Font.Color = vbBlack
End Sub

Sub KLEENAP()
    '
    With Range("P2")
        Range("P2") = ""
    End With
    ActiveSheet.ListObjects(1).Range.AutoFilter field:=14
   
End Sub

Sub KLEENAQ()
    '
    With Range("Q2")
        Range("Q2") = ""
    End With
    ActiveSheet.ListObjects(1).Range.AutoFilter field:=15
   
End Sub

Sub KLEENAM()
    '
    With Range("M2")
        Range("M2") = ""
    End With
    ActiveSheet.ListObjects(1).Range.AutoFilter field:=13
   
End Sub
Sub KLEENAL()
    '
    With Range("L2")
        Range("L2") = ""
    End With
    ActiveSheet.ListObjects(1).Range.AutoFilter field:=12
   
End Sub

Sub SONY3()
    Dim sht         As Worksheet
    Set sht = Sheets("AXXX")
    sht.Range("A4:AA4").AutoFilter field:=12, Criteria1:="=*" & sht.Range("L2").Value & "*"
    sht.Range("A4:AA4").AutoFilter field:=13, Criteria1:="=*" & sht.Range("M2").Value & "*"
    sht.Range("A4:AA4").AutoFilter field:=14, Criteria1:="=*" & sht.Range("P2").Value & "*"
    sht.Range("A4:AA4").AutoFilter field:=15, Criteria1:="=*" & sht.Range("Q2").Value & "*"
End Sub

Sub PVTOPTS()
    '
    ' PVT TOPTS Macro
    ' Keyboard Shortcut: Ctrl+Shift+Y
    ' Define books
    Dim wb1         As Workbook
    Set wb1 = ActiveWorkbook
    wb1.Worksheets("IFS8").Select
    Range("A5:L5").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.CurrentRegion.Offset(4).Resize(Selection.CurrentRegion.Rows.Count - 5).Select
    Selection.Copy
    ThisWorkbook.Activate
    Sheets("IFS9").Select
    Range("TAB_008_CUR[Assessor name]").Select
    ActiveSheet.Paste
    Application.CutCopyMode = FALSE
    ' Refresh all
    ThisWorkbook.RefreshAll
    ' Check filters
    Sheets("PVTS").Select
    If Range("N5") <> "(All)" Then Range("N5") = "(All)"
    If Range("N6") <> "(All)" Then Range("N6") = "(All)"
    If Range("N7") <> "(All)" Then Range("N7") = "(All)"
    If Range("N8") <> "(All)" Then Range("N8") = "(All)"
    If Range("R5") <> "Y" Then Range("R5") = "Y"
    If Range("R6") <> "N" Then Range("R6") = "N"
    If Range("R7") <> "N" Then Range("R7") = "N"
    If Range("R8") <> "N" Then Range("R8") = "N"
    If Range("V5") <> "N" Then Range("V5") = "N"
    If Range("V6") <> "N" Then Range("V6") = "N"
    If Range("V7") <> "N" Then Range("V7") = "N"
    If Range("V8") <> "N" Then Range("V8") = "N"
    If Range("Z5") <> "Y" Then Range("Z5") = "Y"
    If Range("Z6") <> "Y" Then Range("Z6") = "Y"
    If Range("Z7") <> "N" Then Range("Z7") = "N"
    If Range("Z8") <> "N" Then Range("Z8") = "N"
    If Range("AD5") <> "Y" Then Range("AD5") = "Y"
    If Range("AD6") <> "Y" Then Range("AD6") = "Y"
    If Range("AD7") <> "Y" Then Range("AD7") = "Y"
    If Range("AD8") <> "N" Then Range("AD8") = "N"
    If Range("AH5") <> "Y" Then Range("AH5") = "Y"
    If Range("AH6") <> "Y" Then Range("AH6") = "Y"
    If Range("AH7") <> "Y" Then Range("AH7") = "Y"
    If Range("AH8") <> "Y" Then Range("AH8") = "Y"
    If Range("AP8") <> "Y" Then Range("AP8") = "Y"
    If Range("AT8") <> "Y" Then Range("AT8") = "Y"
    ' Reapplys
    Sheets("NALC").Select
    If Range("E5") <> "(All)" Then Range("E5") = "(All)"
    If Range("E6") <> "(All)" Then Range("E6") = "(All)"
    If Range("E7") <> "(All)" Then Range("E7") = "(All)"
    If Range("E8") <> "(All)" Then Range("E8") = "(All)"
    ActiveSheet.AutoFilter.ApplyFilter
    Sheets("REJS").Select
    If Range("F5") <> "N" Then Range("F5") = "N"
    If Range("F6") <> "N" Then Range("F6") = "N"
    If Range("F7") <> "N" Then Range("F7") = "N"
    If Range("F8") <> "N" Then Range("F8") = "N"
    ActiveSheet.AutoFilter.ApplyFilter
    ' New part
    Sheets("FUSE").Select
    If Range("M15") > 0 Then
        Sheets("REJS").Select
        Range("F11:G11").Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.Copy
        Sheets("REASSIGN").Select
        Dim foundBlank1 As Range
        Set foundBlank1 = Range("F10:F2000").Find(What:="", lookat:=xlWhole)
        foundBlank1.Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                               :=False, Transpose:=False
    End If
    '   TRACK
    Sheets("FUSE").Select
    If Range("L15") > 0 Then
        Sheets("NALC").Select
        Range("D11:F11").Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.Copy
        Sheets("TRACK").Select
        Dim foundBlank2 As Range
        Set foundBlank2 = Range("A10:A10000").Find(What:="", lookat:=xlWhole)
        foundBlank2.Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                               :=False, Transpose:=False
    End If
    '   TRACK SNAP
    Sheets("FUSE").Select
    If Range("K15") = "CLEAR" Then
        Sheets("TRACK").Select
        Columns("H:H").Select
        Selection.Copy
        Dim foundBlank As Range
        Set foundBlank = Range("I1:BB1").Find(What:="", lookat:=xlWhole)
        foundBlank.Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                               :=False, Transpose:=False
    End If
    Application.CutCopyMode = FALSE
    '   Dater
    wb1.Activate
    Sheets("IFS8").Select
    Dim last_row    As Integer
    last_row = Cells(Rows.Count, 1).End(xlUp).MergeArea.UnMerge
    last_row = Cells(Rows.Count, 1).End(xlUp).Select
    Debug.Print last_row
   
    Selection.Copy
    ThisWorkbook.Activate
    Sheets("TRACK").Select
    Cells(9, ActiveCell.Column).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                           :=False, Transpose:=False
    With ActiveCell
        .Value = Mid(.Value, 56)
       
    End With
   
    Cells(10, ActiveCell.Column).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                           :=False, Transpose:=False
    With ActiveCell
        .Value = Mid(.Value, 45)
        ActiveCell = DateValue(Format(.Value, "mm/dd/yyyy"))
    End With
   
    wb1.Close SaveChanges:=False
    '''''
    ThisWorkbook.Activate
    Sheets("FUSE").Select
    Range("K18") = "DONE"
    With Range("L18")
        .Value = Date
        .NumberFormat = "dd/mm/yyyy"
    End With
    With Range("M18")
        .Value = Time
        .NumberFormat = "hh:mm"
    End With
    Sheets("TRACK").Select
    MsgBox "Set Date And TIME now!"
End Sub
 
Upvote 0
Hi @DanteAmor, the macro works on its own, so I have marked this thread as solved. However the freezing starts as soon as any other macro is enabled.
One other macro filters M5:M555 based on M2:02 so I think it will be better to merge the two. I have therefore created a new thread. I was just about sharing that with you but I see you have just responded to it so I will continue there too. Thank you
 
Upvote 0
The macros in post #18 don't run on their own, maybe you have other code in the sheet events. Those are the ones you should disable.
Or with which of the macros in post #18 does excel freeze?
 
Upvote 0
Status
Not open for further replies.

Similar threads

duteberta
  • Question
VBA code to auto sort table based on any change within a specific column
2
Replies
17
Views
558
Peter_SSs
Peter_SSs
Y
  • Solved
Highlighting selected words in a column.
Replies
6
Views
253
Akuini
Akuini
J
  • Question
Highlight Search Result
Replies
5
Views
188
Peter_SSs
Peter_SSs
A
  • Question
VBA Highlight cell if contains specific text
Replies
4
Views
294
DanteAmor
DanteAmor
G
  • Solved
Format & Protect range of cells using VBA
Replies
7
Views
377
Gajendran Yadhav
G

Forum statistics

Threads
1,216,109
Messages
6,128,883
Members
449,477
Latest member
panjongshing

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top