Macro Not Working for Search in Multiple Columns

**vcs1161** · 03-07-2013, 11:35 AM

I have this macro that seems to have a quirk where it is not looking through all the columns that are selected. This is looking for keywords and changing the font to bold red type for just those keywords in a cell. It works but am now seeing that it is not looking through all the columns selected in the range. Any thoughts of what you see could be the problem is greatly appreciated.

Sub TestMultipleColumn()
Dim r As Range, LastRow As Long
Dim rs As Range
 Dim v As Variant, s As String
 Dim TextEntry As String
 Dim Msg As String
 Dim Entry As String
 Dim x As Long, where As Long
 Dim Rng As Range
 Dim CellCount As String
 
 Set rs = Application.InputBox(Prompt:="Select the Column for Lookup", Title:="Range Select", Type:=8)
 rs.Name = "Lookup"

 Msg = "Separate Each Keyword or String with a Comma (ex. string1,string2)"
 TextEntry = InputBox(Msg)
 
LastRow = Cells(Cells.Rows.Count, "A").End(xlUp).Row
Entry = TextEntry
v = Split(Entry, ",")
For Each r In Range("Lookup")
     For x = 0 To UBound(v)
         If InStr(1, r.Value, v(x), vbTextCompare) > 0 Then
         where = InStr(1, r.Value, v(x), vbTextCompare)
         With r
             .Characters(Start:=where, Length:=Len(v(x))).Font.FontStyle = "Bold"
             .Characters(Start:=where, Length:=Len(v(x))).Font.ColorIndex = 3
         End With
         End If
     
    Next
 Next r
     Range("A1").Select
     Exit Sub

End Sub

**tigeravatar** · 03-07-2013, 02:26 PM

vcs1161,

Here is an overhauled version of your code, with comments. Give it a try:

Sub TestMultipleColumn()
    
    'Declare variables
    Dim rngSelection As Range   'Used to store the user-selected range
    Dim SelectionCell As Range  'Used to loop through each cell in rngSelection
    Dim arrTerms() As String    'Used to split the user-entered terms into an array
    Dim strTerms As String      'used to store the user-entered terms
    Dim strKeyword As Variant   'Used to loop through arrTerms
    Dim lStart As Long          'Used to check if strKeyword exists within SelectionCell
    
    On Error Resume Next    'Prevent error if user presses Cancel
    'Prompt user to select the range to search
    Set rngSelection = Application.InputBox("Select the range to search:", "Range Select", Selection.Address, Type:=8)
    On Error GoTo 0         'Remove the On Error Resume Next condition
    If rngSelection Is Nothing Then Exit Sub    'Pressed Cancel, exit macro
    
    'Prompt user to enter the terms to search for in each cell
    strTerms = InputBox("Provide the keywords to search for" & Chr(10) & _
                        "Separate each keyword with a comma "",""" & Chr(10) & _
                        "Example: string1,string2)")
    If Len(strTerms) = 0 Then Exit Sub  'Pressed Cancel, exit macro
    
    On Error GoTo CleanExit             'Assume code will fail and provide an error handler
    Application.ScreenUpdating = False  'Disable screenupdating to prevent "screen flickering" and allow code to run faster"
    
    'Split strTerms into the array arrTerms
    arrTerms = Split(strTerms, ",")
    
    'Go through each cell in rngSelection
    For Each SelectionCell In rngSelection.Cells
        'Go through each keyword
        For Each strKeyword In arrTerms
            'Check if keyword exists
            lStart = InStr(1, SelectionCell.Text, strKeyword, vbTextCompare)
            If lStart > 0 Then
                'Found to exist, make keyword bold and red
                With SelectionCell.Characters(lStart, Len(strKeyword)).Font
                    .FontStyle = "Bold"
                    .ColorIndex = 3
                End With
            End If
        Next strKeyword 'Advance loop through keywords
    Next SelectionCell  'Advance loop for rngSelection
    
'Code will exit here if there is an error
'Code will also exit here if code reaches this point normally (ran successfully)
CleanExit:
    Application.ScreenUpdating = True   'Re-enable screenupdating
    
    'If there was an error, display the error message and clear the error
    If Err.Number <> 0 Then
        MsgBox Err.Description, , "Error: " & Err.Number
        Err.Clear
    End If
    
    'Object and array variable cleanup
    Set rngSelection = Nothing
    Set SelectionCell = Nothing
    Erase arrTerms
    
End Sub

**vcs1161** · 03-07-2013, 02:39 PM

I am getting this error message on the last line "Erase arrTerms"

Error 1004 "Unable to get the Text Property of the Range Class"

**tigeravatar** · 03-07-2013, 02:49 PM

Alternately, if you could upload a sample workbook that is experiencing the error, I can take a look at it, because I have been unable to duplicate that error.

**tigeravatar** · 03-07-2013, 02:46 PM

Did you alter the code? arrTerms() should be dimmed as String, not Range

**vcs1161** · 03-07-2013, 03:42 PM

I did not alter the code but it seems to do this and hang when I select a range of columns. But it does work when I select a range of specific cells. There will be times when selecting the column will be more efficient since there can be some very large worksheets. The other thing I noticed is that sometimes it will not find the part of a string after the second, third, etc. times. For instance, I ran this again after my first successful run was complete and ran another search for "wed" but it did not find that in Wednesday (column A). And yet it was found after I reset the font and ran it in the first pass/attempt.

I attached a file that I am testing this on.

TestingMacroSearch.xlsx