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 would like to perform another find on '' AllRng" obtained above. Can you suggest me on how this can be obtained.
TIA

 

[Fluff]

I don't understand, you are already doing multiple searches.

 

[gauthamreddy]

The above code returns a few cells that contain the word right. They are then sorted to make sure they are on top of the sheet. Now I would like to use another similar code to search for a few words but only on the rows that we put to the top and not on the whole sheet.

 

[Fluff]

How about

   [COLOR=#0000ff]Dim Rws As Long[/COLOR]      'Add this to the Dim statements at the top of your code
   
   Next i
   [COLOR=#0000ff]Rws = AllRng.Count[/COLOR]   'Add this as shown here
   Rows(2).Resize(AllRng.Count).Insert
   AllRng.EntireRow.Copy Range("A2")
   AllRng.EntireRow.Delete
'   then add a search routine searching the specific rows something like this
   Set rng = [COLOR=#0000ff]Rows("2:" & Rws)[/COLOR].Find(What:=myValue, lookIn:=xlFormulas, LookAt:=xlPart, _
         SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False)

 

[gauthamreddy]

How about

   [COLOR=#0000ff]Dim Rws As Long[/COLOR]      'Add this to the Dim statements at the top of your code
   
   Next i
   [COLOR=#0000ff]Rws = AllRng.Count[/COLOR]   'Add this as shown here
   Rows(2).Resize(AllRng.Count).Insert
   AllRng.EntireRow.Copy Range("A2")
   AllRng.EntireRow.Delete
'   then add a search routine searching the specific rows something like this
   Set rng = [COLOR=#0000ff]Rows("2:" & Rws)[/COLOR].Find(What:=myValue, lookIn:=xlFormulas, LookAt:=xlPart, _
         SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False)

That didn't work.

Here's is the code if you can take a look at it

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
 
         If oldrngrow1 = rng1.Row Then
            Exit Do
         End If
       Loop
     
   Next j
 
skip:
    Call OptimizeCode_End
End Sub

 

[Fluff]

You've missed the colon after the 2

Set rng1 = Rows("2:"

 

[gauthamreddy]

You've missed the colon after the 2

Set rng1 = Rows("2:"

I was just checking if it worked without a colon. Both ways was not working.

 

[Fluff]

Are you sure that the value you're looking for occurs in those rows?

 

[gauthamreddy]

Are you sure that the value you're looking for occurs in those rows?

Yes I found them manually and I am looking only for those values that are in the rows.

 

[Fluff]

You missed a line

        Do While rng1.Column = 11
            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
          [COLOR=#ff0000]Set rng1 = Rows("2:" & Rws).FindNext(After:=rng1)
[/COLOR]
         If oldrngrow1 = rng1.Row Then