gauthamreddy

New Member
Joined
Jan 5, 2018
Messages
16
Hi, I have this code that finds the specific work from the column selected in the listbox. The problem I am facing is it only highlights if the cell has that word only once. If the cell has the same word multiple times it is not highlighting those.
Here is the code
Code:
              Dim rng As Range
              Dim i As Long
                Dim oldrngrow As Long
                Dim myValue As Variant
                 For i = 0 To Me.ListBox4.ListCount - 1
                   myValue = Me.ListBox4.List(i)
                   If myValue = vbNullString Then
                      End
                   End If
                   
                   Set rng = Cells.Find(What:=myValue, After:=Cells(2, ListBox3.ListIndex + 1), LookIn:=xlFormulas, LookAt _
                      :=xlPart, SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False)
                   If rng Is Nothing Then
                      GoTo skip
                   End If
                
                   oldrngrow = rng.Row
                   Do While rng.Column = ListBox3.ListIndex + 1
                      rng.Characters(InStr(rng, myValue), Len(myValue)).Font.ColorIndex = 4
                      rng.Characters(InStr(rng, myValue), Len(myValue)).Font.Bold = True
                      rng.Characters(InStr(rng, myValue), Len(myValue)).Font.Size = 14
                      Set rng = Cells.FindNext(After:=rng)
                      If oldrngrow = rng.Row Then
                        Exit Do
                      End If


                   Loop
                Next i

Your help is appreciated.
Thanks
Gautham
 

Excel Facts

Copy a format multiple times
Select a formatted range. Double-click the Format Painter (left side of Home tab). You can paste formatting multiple times. Esc to stop
Hi,
welcome to forum

untested but see if this update to your code does what you want

Code:
Dim rng As Range
    Dim i As Long
    Dim oldrngrow As Long
    Dim myValue As Variant
    Dim firstaddress As String


    For i = 0 To Me.ListBox4.ListCount - 1
        myValue = Me.ListBox4.List(i)
        If myValue = vbNullString Then Exit Sub
        
        Set rng = Cells.Find(What:=myValue, After:=Cells(2, ListBox3.ListIndex + 1), LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False)
        If Not rng Is Nothing Then
            firstaddress = rng.Address
            
            Do
                rng.Characters(InStr(rng, myValue), Len(myValue)).Font.ColorIndex = 4
                rng.Characters(InStr(rng, myValue), Len(myValue)).Font.Bold = True
                rng.Characters(InStr(rng, myValue), Len(myValue)).Font.Size = 14
                Set rng = Cells.FindNext(After:=rng)
                If rng Is Nothing Then Exit Do
            Loop While firstaddress <> rng.Address
        End If
    Next i

Dave
 
Upvote 0
My take on what the OP is after
Code:
   Dim rng As Range
   Dim i As Long
   Dim oldrngrow As Long
   Dim myValue As Variant
   Dim Strt As Long
   
   For i = 0 To Me.ListBox4.ListCount - 1
      myValue = Me.ListBox4.list(i)
      If myValue = vbNullString Then
      End
      End If
      
      Set rng = Cells.Find(What:=myValue, After:=Cells(2, ListBox3.ListIndex + 1), LookIn:=xlFormulas, LookAt _
         :=xlPart, SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False)
      If rng Is Nothing Then
         GoTo skip
      End If
      
      oldrngrow = rng.Row
      Do While rng.Column = ListBox3.ListIndex + 1
         Strt = 1
         Do While Strt > 0
            rng.Characters(InStr(Strt, rng, myValue), Len(myValue)).Font.ColorIndex = 4
            rng.Characters(InStr(Strt, rng, myValue), Len(myValue)).Font.Bold = True
            rng.Characters(InStr(Strt, rng, myValue), Len(myValue)).Font.Size = 14
            Strt = Strt + 1
            Strt = InStr(Strt, rng, myValue)
         Loop
         Set rng = Cells.FindNext(After:=rng)
         If oldrngrow = rng.Row Then
            Exit Do
         End If
      Loop
   Next i
 
Upvote 0
My take on what the OP is after
Code:
   Dim rng As Range
   Dim i As Long
   Dim oldrngrow As Long
   Dim myValue As Variant
   Dim Strt As Long
   
   For i = 0 To Me.ListBox4.ListCount - 1
      myValue = Me.ListBox4.list(i)
      If myValue = vbNullString Then
      End
      End If
      
      Set rng = Cells.Find(What:=myValue, After:=Cells(2, ListBox3.ListIndex + 1), LookIn:=xlFormulas, LookAt _
         :=xlPart, SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False)
      If rng Is Nothing Then
         GoTo skip
      End If
      
      oldrngrow = rng.Row
      Do While rng.Column = ListBox3.ListIndex + 1
         Strt = 1
         Do While Strt > 0
            rng.Characters(InStr(Strt, rng, myValue), Len(myValue)).Font.ColorIndex = 4
            rng.Characters(InStr(Strt, rng, myValue), Len(myValue)).Font.Bold = True
            rng.Characters(InStr(Strt, rng, myValue), Len(myValue)).Font.Size = 14
            Strt = Strt + 1
            Strt = InStr(Strt, rng, myValue)
         Loop
         Set rng = Cells.FindNext(After:=rng)
         If oldrngrow = rng.Row Then
            Exit Do
         End If
      Loop
   Next i

Thanks for the answer. It worked like a charm.
I have another issue now. If I am trying to search for word "error" it doesn't pick up the word "Error" starting with a Capital 'E'. The match case doesn't seem to work. Can you please help me with that?
 
Upvote 0
One option is to put this at the vary top of the module containing the code (ie before any subs)
Code:
Option Compare Text
 
Upvote 0
One option is to put this at the vary top of the module containing the code (ie before any subs)
Code:
Option Compare Text

Awesome. It worked perfect. You seem to be a master. I have one last question. I am really new to VBA. I wanted to know if there is any way to bring all the rows with the highlighted words on to the top of the sheet and the file is very large(around 80k rows).
I really appreciate your help.
TIA.
 
Upvote 0
Try
Code:
   Dim rng As Range
   Dim AllRng As Range
   Dim i As Long
   Dim oldrngrow As Long
   Dim myValue As Variant
   Dim Strt As Long
   
   For i = 0 To Me.ListBox4.ListCount - 1
      myValue = Me.ListBox4.list(i)
      If myValue = vbNullString Then
      End
      End If
      
      Set rng = Cells.Find(What:=myValue, LookIn:=xlFormulas, LookAt:=xlPart, _
         SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False)
      If rng Is Nothing Then
         GoTo skip
      End If
      
      oldrngrow = rng.Row
      Do While rng.Column = ListBox3.ListIndex + 1
         Strt = 1
         Do While Strt > 0
            rng.Characters(InStr(Strt, rng, myValue), Len(myValue)).Font.ColorIndex = 4
            rng.Characters(InStr(Strt, rng, myValue), Len(myValue)).Font.Bold = True
            rng.Characters(InStr(Strt, rng, myValue), Len(myValue)).Font.Size = 14
            Strt = Strt + 1
            Strt = InStr(Strt, rng, myValue)
         Loop
         If AllRng Is Nothing Then
            Set AllRng = rng
         Else
            Set AllRng = Union(AllRng, rng)
         End If

         Set rng = Cells.FindNext(After:=rng)
         If oldrngrow = rng.Row Then
            Exit Do
         End If
      Loop
   Next i
   Rows(2).Resize(AllRng.Count).Insert
   AllRng.EntireRow.Copy Range("A2")
   AllRng.EntireRow.Delete
 
Upvote 0
Try
Code:
   Dim rng As Range
   Dim AllRng As Range
   Dim i As Long
   Dim oldrngrow As Long
   Dim myValue As Variant
   Dim Strt As Long
   
   For i = 0 To Me.ListBox4.ListCount - 1
      myValue = Me.ListBox4.list(i)
      If myValue = vbNullString Then
      End
      End If
      
      Set rng = Cells.Find(What:=myValue, LookIn:=xlFormulas, LookAt:=xlPart, _
         SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False)
      If rng Is Nothing Then
         GoTo skip
      End If
      
      oldrngrow = rng.Row
      Do While rng.Column = ListBox3.ListIndex + 1
         Strt = 1
         Do While Strt > 0
            rng.Characters(InStr(Strt, rng, myValue), Len(myValue)).Font.ColorIndex = 4
            rng.Characters(InStr(Strt, rng, myValue), Len(myValue)).Font.Bold = True
            rng.Characters(InStr(Strt, rng, myValue), Len(myValue)).Font.Size = 14
            Strt = Strt + 1
            Strt = InStr(Strt, rng, myValue)
         Loop
         If AllRng Is Nothing Then
            Set AllRng = rng
         Else
            Set AllRng = Union(AllRng, rng)
         End If

         Set rng = Cells.FindNext(After:=rng)
         If oldrngrow = rng.Row Then
            Exit Do
         End If
      Loop
   Next i
   Rows(2).Resize(AllRng.Count).Insert
   AllRng.EntireRow.Copy Range("A2")
   AllRng.EntireRow.Delete
Many thanks for the solution. It worked perfect. Thanks again.
 
Upvote 0
One option is to put this at the vary top of the module containing the code (ie before any subs)
Code:
Option Compare Text
The alternate to that (if you don't want all comparisons made within the code in that module to be case sensitive) is to add the fourth, optional argument to the InStr function call. Instead of writing this...

InStr(Strt, rng, myValue)

write this instead (for each search that you want to be case insensitive)...

InStr(Strt, rng, myValue, vbTextCompare)
 
Last edited:
Upvote 0

Forum statistics

Threads
1,213,551
Messages
6,114,266
Members
448,558
Latest member
aivin

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