text finder macro

[gauthamreddy]

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

              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

 

[gauthamreddy]

I have added the line and that didn't work either

 

[Fluff]

Could you re-post the code you are using now?

 

[gauthamreddy]

Private Sub btnOK_Click()
                
    Call OptimizeCode_Begin
        
   Dim rng As Range
   Dim rng1 As Range
        
   Dim AllRng As Range
   Dim AllRng1 As Range
   
   Dim i As Long
   Dim j As Long
   
   Dim oldrngrow As Long
   Dim oldrngrow1 As Long
   
   Dim myValue As Variant
   Dim myValue1 As Variant
   
   Dim Strt As Long
   Dim Strt1 As Long
   Dim Rws As Long
   
 '        Not present words
    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
         
         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
   Rws = AllRng.Count
    Rows(2).Resize(AllRng.Count).Insert
   AllRng.EntireRow.Copy Range("A2")
AllRng.EntireRow.Delete
           
'Highlight in red
      
         For j = 0 To Me.ListBox5.ListCount - 1


    myValue1 = Me.ListBox5.List(j)
    If myValue1 = vbNullString Then
    End
    End If
    Set rng1 = Rows("2:" & Rws).Find(What:=myValue1, LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False)
        
    If rng1 Is Nothing Then
        GoTo skip
    End If
    
    oldrngrow1 = rng1.Row
    
        Do While rng1.Column = ListBox3.ListIndex + 1
            Strt1 = 1
            Do While Strt1 > 0
                rng1.Characters(InStr(Strt1, rng1, myValue1), Len(myValue1)).Font.ColorIndex = 3
                rng1.Characters(InStr(Strt1, rng1, myValue1), Len(myValue1)).Font.Bold = True
                rng1.Characters(InStr(Strt1, rng1, myValue1), Len(myValue1)).Font.size = 14
                Strt1 = Strt1 + 1
                Strt1 = InStr(Strt1, rng1, myValue1)
            Loop
 Set rng1 = Cells.FindNext(After:=rng1)
         If oldrngrow1 = rng1.Row Then
            Exit Do
         End If
       Loop
     
   Next j
 
skip:
    Call OptimizeCode_End
End Sub

This is the code that I am using

 

[Fluff]

This line should be as I showed in post#20

Set rng1 = Cells.FindNext(After:=rng1)

That said, it will not solve the problem. Is this new search meant to be searching the same column as the original search?

 

[gauthamreddy]

Yes it should search the same column.

 

[Fluff]

Give this a go

   For j = 0 To Me.ListBox5.ListCount - 1
      myValue1 = Me.ListBox5.list(j)
      If myValue1 = vbNullString Then
         Exit Sub
      End If
      Set rng1 = Cells(1, ListBox3.ListIndex + 1).Resize(Rws + 1).Find(What:=myValue1, lookIn:=xlFormulas, LookAt _
         :=xlPart, SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False)
      
      If rng1 Is Nothing Then
         GoTo skip
      End If
      
      oldrngrow1 = rng1.Row
      
      Do While rng1.Column = ListBox3.ListIndex + 1
         Strt1 = 1
         Do While Strt1 > 0
            rng1.Characters(InStr(Strt1, rng1, myValue1), Len(myValue1)).Font.ColorIndex = 3
            rng1.Characters(InStr(Strt1, rng1, myValue1), Len(myValue1)).Font.bold = True
            rng1.Characters(InStr(Strt1, rng1, myValue1), Len(myValue1)).Font.size = 14
            Strt1 = Strt1 + 1
            Strt1 = InStr(Strt1, rng1, myValue1)
         Loop
         Set rng1 = Cells(1, ListBox3.ListIndex + 1).FindNext(After:=rng1)
         
         If oldrngrow1 = rng1.Row Then
            Exit Do
         End If
      Loop
   Next j

 

[gauthamreddy]

I tried this and it didn't work. Thank you though.

 

[Fluff]

How about making this change

 Set rng1 = Cells(1, ListBox3.ListIndex + 1)[COLOR=#ff0000].Resize(Rws + 1)[/COLOR].FindNext(After:=rng1)

 

[gauthamreddy]

How about making this change

 Set rng1 = Cells(1, ListBox3.ListIndex + 1)[COLOR=#ff0000].Resize(Rws + 1)[/COLOR].FindNext(After:=rng1)

Many Thanks for this. It worked!!

 

[Fluff]

Glad to help & thanks for the feedback