text finder macro

G

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

What do {} around a formula in the formula bar mean?
{Formula} means the formula was entered using Ctrl+Shift+Enter signifying an old-style array formula.
Sort by date Sort by votes
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
Fluff said:
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
Click to expand...

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
Fluff said:
One option is to put this at the vary top of the module containing the code (ie before any subs)
Code: 
Option Compare Text
Click to expand...

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
Fluff said:
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
Click to expand...
Many thanks for the solution. It worked perfect. Thanks again.
 
Upvote 0
Fluff said:
One option is to put this at the vary top of the module containing the code (ie before any subs)
Code: 
Option Compare Text
Click to expand...
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
You must log in or register to reply here.

Similar threads

trishcollins
  • Solved
VBA to find and bold only certain words in one cell
Replies
5
Views
649
trishcollins
trishcollins
A
  • Solved
This VBA macro does not work - Why? - (expected to capitalize first letter of first word in sentence, following period & space)
Replies
9
Views
401
abramo
A
A
  • Solved
Excel VBA Phone Number Format Issue
Replies
4
Views
386
AnnAnn
A
E
  • Solved
Subroutine to Add Cell Comments Not Updating the Contents Correctly
Replies
7
Views
642
CephasOz
CephasOz
A
  • Question Question
VBA Highlight cell if contains specific text
Replies
4
Views
2K
DanteAmor
DanteAmor

Forum statistics

Threads
1,223,956
Messages
6,175,619
Members
452,661
Latest member
Nonhle

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