VBA check if string contains character from list

[Kra]

Hi all,
I am trying to set up macro which will detect character from list supplied by user in a cell value.

I have 2 sheets: "Data" and "Characters".

In "Characters" user will in write characters which they want to be detected (all in column A, no header). So lets say they want to detect capital O, dash and number 9.
A1 O
A2 -
A3 9

They will paste some report/data dump in sheet called "Data" and then macro will check each cell and highlight it on red if cell value contains any of characters given by user.

 

[Legacy 143009]

Sub findChar()
  Dim characters() As Variant
  Dim chr As Variant

  characters = Worksheets("Characters").Range("A1:A" & Worksheets("Characters").Cells(Rows.Count, 1).End(xlUp).Row)

  For Each chr In characters
    For c = 1 To Worksheets("Data").Cells(1, Columns.Count).End(xlLeft).Column
      For r = 1 To Worksheets("Data").Cells(Rows.Count, 1).End(xlUp).Row
        If Instr(Worksheets("Data").Cells(r, c).Value, chr) > 0 Then
          Worksheets("Data").Cells(r, c).Interior.ColorIndex = 3
        End If
      Next
    Next
  Next
End Sub

 

[kevin9999]

Another option...

Option Explicit
Sub Kra_Replace()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = Worksheets("Characters")
    Set ws2 = Worksheets("Data")
    
    With Application.ReplaceFormat
        .Interior.Color = vbRed
    End With
    
    Dim Arr, i As Long, s As String
    Arr = ws1.Range("A1", ws1.Cells(Rows.Count, "A").End(xlUp))
    For i = LBound(Arr, 1) To UBound(Arr, 1)
        s = Arr(i, 1)
        ws2.UsedRange.Replace s, s, xlPart, , , , , True
    Next i
End Sub

 

[Kra]

Sub findChar()
  Dim characters() As Variant
  Dim chr As Variant

  characters = Worksheets("Characters").Range("A1:A" & Worksheets("Characters").Cells(Rows.Count, 1).End(xlUp).Row)

  For Each chr In characters
    For c = 1 To Worksheets("Data").Cells(1, Columns.Count).End(xlLeft).Column
      For r = 1 To Worksheets("Data").Cells(Rows.Count, 1).End(xlUp).Row
        If Instr(Worksheets("Data").Cells(r, c).Value, chr) > 0 Then
          Worksheets("Data").Cells(r, c).Interior.ColorIndex = 3
        End If
      Next
    Next
  Next
End Sub

It gives Mismatch error on this line:

characters = Worksheets("Characters").Range("A1:A" & Worksheets("Characters").Cells(Rows.Count, 1).End(xlUp).Row)

Names of sheets are correct (no spaces before or after name)

 

[Kra]

Another option...

Option Explicit
Sub Kra_Replace()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = Worksheets("Characters")
    Set ws2 = Worksheets("Data")
 
    With Application.ReplaceFormat
        .Interior.Color = vbRed
    End With
 
    Dim Arr, i As Long, s As String
    Arr = ws1.Range("A1", ws1.Cells(Rows.Count, "A").End(xlUp))
    For i = LBound(Arr, 1) To UBound(Arr, 1)
        s = Arr(i, 1)
        ws2.UsedRange.Replace s, s, xlPart, , , , , True
    Next i

[/QUOTE]

I have no idea why, but this code replaces my "i" letter in string with "I" and marks it red, even if it doesn't have any character from list  (I tested it with these characters

 

[Kra]

Another option...

Option Explicit
Sub Kra_Replace()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = Worksheets("Characters")
    Set ws2 = Worksheets("Data")
   
    With Application.ReplaceFormat
        .Interior.Color = vbRed
    End With
   
    Dim Arr, i As Long, s As String
    Arr = ws1.Range("A1", ws1.Cells(Rows.Count, "A").End(xlUp))
    For i = LBound(Arr, 1) To UBound(Arr, 1)
        s = Arr(i, 1)
        ws2.UsedRange.Replace s, s, xlPart, , , , , True
    Next i
End Sub

Sorry, something went wrong with previous response.

I have no idea why, but this code replaces my "i" letter in string with "I" and marks it red, even if it doesn't have any character from list (I tested it with these characters

)

 

[kevin9999]

Sorry, something went wrong with previous response.

I have no idea why, but this code replaces my "i" letter in string with "I" and marks it red, even if it doesn't have any character from list (I tested it with these charactersView attachment 79305)

I'll really need to see your actual data (using the XL2BB add in or perhaps if you share your file via Google drive, Dropbox etc.) before I can get to the bottom of that one.

 

[Legacy 143009]

This should work:

Sub findChar()
  Dim characters() As Variant
  Dim chr As Variant
  Dim lRow As Integer
  lRow = Worksheets("Characters").Cells(Rows.Count, 1).End(xlUp).Row
  characters = Worksheets("Characters").Range("A1:A" & lRow).Value

  For Each chr In characters
    For c = 1 To Worksheets("Data").Cells(1, Columns.Count).End(xlToLeft).Column
      For r = 1 To Worksheets("Data").Cells(Rows.Count, 1).End(xlUp).Row
        If InStr(Worksheets("Data").Cells(r, c).Value, chr) > 0 Then
          Worksheets("Data").Cells(r, c).Interior.ColorIndex = 3
        End If
      Next
    Next
  Next
End Sub

 

[Kra]

This should work:

Sub findChar()
  Dim characters() As Variant
  Dim chr As Variant
  Dim lRow As Integer
  lRow = Worksheets("Characters").Cells(Rows.Count, 1).End(xlUp).Row
  characters = Worksheets("Characters").Range("A1:A" & lRow).Value

  For Each chr In characters
    For c = 1 To Worksheets("Data").Cells(1, Columns.Count).End(xlToLeft).Column
      For r = 1 To Worksheets("Data").Cells(Rows.Count, 1).End(xlUp).Row
        If InStr(Worksheets("Data").Cells(r, c).Value, chr) > 0 Then
          Worksheets("Data").Cells(r, c).Interior.ColorIndex = 3
        End If
      Next
    Next
  Next
End Sub

Thank you! Works perfectly!

 

[Legacy 143009]

Glad to hear it did work! Thanks for the feedback.