Highlighting Unique List of Words in Each Cell of a Selection of Cells

Description

I feel like the answer is so simple, but I just can't figure it out. I'm developing a code to highlight a list of specified words in each cell of a selection using a Userform input and string splitting. This is a modification of a code I found elsewhere on a public domain. The original code did not use Userform or use capitalization functions in the Module. Before I added the Userform portion of the code, it worked perfectly with the adjustments I made to make the code non-cap-sensitive. The issue seems to come from the Module and not the Userform as far as I can tell. The reoccuring issue is that it will only use the last word in a list provided. The code used and examples of its application are provided below. Any help would be greatly appreciated!

(Ex. 1) Data to be altered:

(Ex. 2) Blank Userform:

(Ex. 3) Filled Userform:

(Ex. 4) Data altered:

*Note: The Scroll Bar in the Userform is currently not implemented.

Module: Mod2HighlightString

    'Updateby Extendoffice
    Application.ScreenUpdating = False
    Dim Rng As Range '-variable to hold each cells value in the selection
    Dim cFnd As String '-variable that holds the user input from the userform
    Dim xTmp As String '-variable for temporary holds on parts of string (I think)
    Dim i As Long '-variable for holding color index value
    Dim j As Variant '-variable for testing a split array
    Dim k As Integer '-variable for a loop
    Dim x As Long '-variable for a loop
    Dim m As Long '-variable for holding number of times a word is in a cell
    Dim y As Long '-variable for holding len function
    Dim Color As String '-variable to hold value provided for desired font color
    Dim xFNum As Integer '-variable for a loop
    Dim xArrFnd As Variant '-variable holds array of words to search for provided from userform
    Dim xStr As String '-variable that temp holds a single string from the array of strings
    Mod2User.Show
    Color = CStr(Mod2User.ComboBox1.Value)
    If Color = "Red" Then i = 3
    If Color = "Green" Then i = 4
    If Color = "Blue" Then i = 5
    If Color = "Cyan" Then i = 8
    If Color = "Pink" Then i = 7
    If Color = "Orange" Then i = 46
    cFnd = CStr(Mod2User.TextBox1.Value) 'InputBox("Please enter the text, separate them by comma:")
    Debug.Print Color; Chr(10); cFnd
    If Len(cFnd) < 1 Then Exit Sub
    'xArrFnd - holds array of words to search for
    xArrFnd = Split(cFnd, Chr(10))
'    j = UBound(xArrFnd)
    
    For Each Rng In Selection
        With Rng
            'rng.value will supply the cells content within the selection
'            Debug.Print .Value
            For xFNum = 0 To UBound(xArrFnd)
                'xStr - Temp holds a single string from the array of strings
                xStr = xArrFnd(xFNum)
                y = Len(xStr)
                m = UBound(Split(UCase(Rng.Value), UCase(xStr)))
                
                j = Split(UCase(Rng.Value), UCase(xStr))
                
                Debug.Print "word "; xFNum; " is "; xStr
                Debug.Print "y:"; y; " m: "; m
                Debug.Print "Split: ["; UCase(Rng.Value); "], using: ["; UCase(xStr); "]"
                
                For k = 0 To UBound(j)
                    Debug.Print "Result: "; j(k)
                Next k
                
                If m > 0 Then
                    xTmp = ""
                    For x = 0 To m - 1
                        xTmp = xTmp & Split(UCase(Rng.Value), UCase(xStr))(x)
                        Debug.Print UCase(xStr)
                        Debug.Print UCase(Rng.Value)
                        
'                        Debug.Print "at x ="; x; "first xtmp = "; xTmp
                        .Characters(Start:=Len(xTmp)   1, Length:=y).Font.ColorIndex = i
                        xTmp = xTmp & xStr
                    Next
                End If
            Next xFNum
        End With
    Next Rng
    Unload Mod2User
    Application.ScreenUpdating = True
End Sub

Userform: Mod2User

Private m_Cancelled As Boolean

Public Property Get Cancelled() As Variant
    Cancelled = m_Cancelled
End Property

Private Sub ComboBox1_Change()

End Sub

Private Sub Label1_Click()

End Sub

Private Sub ScrollBar1_Change()

End Sub

Private Sub TextBox1_Change()
    
End Sub

Private Sub UserForm_Click()

End Sub



Private Sub CommandButton1_Click()
    Hide
End Sub

Private Sub UserForm_Initialize()

    With Mod2User
      .Width = Application.Width * 0.293
      .Height = Application.Height * 0.35
    End With
    
    
    With ComboBox1
        .Clear
        .AddItem "Red"
        .AddItem "Green"
        .AddItem "Blue"
        .AddItem "Cyan"
        .AddItem "Pink"
        .AddItem "Orange"
    End With
    
    TextBox1.MultiLine = True
'    TextBox1.ScrollBars =

End Sub

Private Sub UserForm_QueryClose(Cancel As Integer _
                                        , CloseMode As Integer)
    
    ' Prevent the form being unloaded
    If CloseMode = vbFormControlMenu Then Cancel = True
    
    ' Hide the Userform and set cancelled to true
    Hide
    m_Cancelled = True
    
End Sub

Function GetComboBox1() As String
    GetComboBox1 = CStr(ComboBox1.Value)
End Function

Debug.Print Results

Blue
the
downey
fierce
word  0  is the

y: 4  m:  0 
Split: [THE CAT GOES TO THE MOON ON A FINE SUNDAY AFTERNOON IF THE BAKER IS IN THE ], using: [THE
]
Result: THE CAT GOES TO THE MOON ON A FINE SUNDAY AFTERNOON IF THE BAKER IS IN THE 
word  1  is downey

y: 7  m:  0 
Split: [THE CAT GOES TO THE MOON ON A FINE SUNDAY AFTERNOON IF THE BAKER IS IN THE ], using: [DOWNEY
]
Result: THE CAT GOES TO THE MOON ON A FINE SUNDAY AFTERNOON IF THE BAKER IS IN THE 
word  2  is fierce
y: 6  m:  0 
Split: [THE CAT GOES TO THE MOON ON A FINE SUNDAY AFTERNOON IF THE BAKER IS IN THE ], using: [FIERCE]
Result: THE CAT GOES TO THE MOON ON A FINE SUNDAY AFTERNOON IF THE BAKER IS IN THE 
word  0  is the

y: 4  m:  0 
Split: [ROBERT DOWNEY JUNIOR GOES TO MEMPHIS TO PLAY FOOTBALL], using: [THE
]
Result: ROBERT DOWNEY JUNIOR GOES TO MEMPHIS TO PLAY FOOTBALL
word  1  is downey

y: 7  m:  0 
Split: [ROBERT DOWNEY JUNIOR GOES TO MEMPHIS TO PLAY FOOTBALL], using: [DOWNEY
]
Result: ROBERT DOWNEY JUNIOR GOES TO MEMPHIS TO PLAY FOOTBALL
word  2  is fierce
y: 6  m:  0 
Split: [ROBERT DOWNEY JUNIOR GOES TO MEMPHIS TO PLAY FOOTBALL], using: [FIERCE]
Result: ROBERT DOWNEY JUNIOR GOES TO MEMPHIS TO PLAY FOOTBALL
word  0  is the

y: 4  m:  0 
Split: [THE OOMPA LOOPAS WERE FIERCE FIGHTERS], using: [THE
]
Result: THE OOMPA LOOPAS WERE FIERCE FIGHTERS
word  1  is downey

y: 7  m:  0 
Split: [THE OOMPA LOOPAS WERE FIERCE FIGHTERS], using: [DOWNEY
]
Result: THE OOMPA LOOPAS WERE FIERCE FIGHTERS
word  2  is fierce
y: 6  m:  1 
Split: [THE OOMPA LOOPAS WERE FIERCE FIGHTERS], using: [FIERCE]
Result: THE OOMPA LOOPAS WERE 
Result:  FIGHTERS
FIERCE
THE OOMPA LOOPAS WERE FIERCE FIGHTERS
word  0  is the

y: 4  m:  0 
Split: [THE DOG HAS A A FIERCE PERSONALITY AND ONLY GOES NUMBER 2 ON THE NEIGHBORS YARD], using: [THE
]
Result: THE DOG HAS A A FIERCE PERSONALITY AND ONLY GOES NUMBER 2 ON THE NEIGHBORS YARD
word  1  is downey

y: 7  m:  0 
Split: [THE DOG HAS A A FIERCE PERSONALITY AND ONLY GOES NUMBER 2 ON THE NEIGHBORS YARD], using: [DOWNEY
]
Result: THE DOG HAS A A FIERCE PERSONALITY AND ONLY GOES NUMBER 2 ON THE NEIGHBORS YARD
word  2  is fierce
y: 6  m:  1 
Split: [THE DOG HAS A A FIERCE PERSONALITY AND ONLY GOES NUMBER 2 ON THE NEIGHBORS YARD], using: [FIERCE]
Result: THE DOG HAS A A 
Result:  PERSONALITY AND ONLY GOES NUMBER 2 ON THE NEIGHBORS YARD
FIERCE
THE DOG HAS A A FIERCE PERSONALITY AND ONLY GOES NUMBER 2 ON THE NEIGHBORS YARD
word  0  is the

y: 4  m:  0 
Split: [CATS SECRETLY LOVE DOGS BUT CANT OWN UP TO IT], using: [THE
]
Result: CATS SECRETLY LOVE DOGS BUT CANT OWN UP TO IT
word  1  is downey

y: 7  m:  0 
Split: [CATS SECRETLY LOVE DOGS BUT CANT OWN UP TO IT], using: [DOWNEY
]
Result: CATS SECRETLY LOVE DOGS BUT CANT OWN UP TO IT
word  2  is fierce
y: 6  m:  0 
Split: [CATS SECRETLY LOVE DOGS BUT CANT OWN UP TO IT], using: [FIERCE]
Result: CATS SECRETLY LOVE DOGS BUT CANT OWN UP TO IT
word  0  is the

y: 4  m:  0 
Split: [CHUCK NORRIS IS A PERSON LIKE YOU AND I], using: [THE
]
Result: CHUCK NORRIS IS A PERSON LIKE YOU AND I
word  1  is downey

y: 7  m:  0 
Split: [CHUCK NORRIS IS A PERSON LIKE YOU AND I], using: [DOWNEY
]
Result: CHUCK NORRIS IS A PERSON LIKE YOU AND I
word  2  is fierce
y: 6  m:  0 
Split: [CHUCK NORRIS IS A PERSON LIKE YOU AND I], using: [FIERCE]
Result: CHUCK NORRIS IS A PERSON LIKE YOU AND I
word  0  is the

y: 4  m:  0 
Split: [HARLM SHAKE WAS A VIBE], using: [THE
]
Result: HARLM SHAKE WAS A VIBE
word  1  is downey

y: 7  m:  0 
Split: [HARLM SHAKE WAS A VIBE], using: [DOWNEY
]
Result: HARLM SHAKE WAS A VIBE
word  2  is fierce
y: 6  m:  0 
Split: [HARLM SHAKE WAS A VIBE], using: [FIERCE]
Result: HARLM SHAKE WAS A VIBE
word  0  is the

y: 4  m:  0 
Split: [WHEN I GO TO FRANCE I WILL EAT SNAIL], using: [THE
]
Result: WHEN I GO TO FRANCE I WILL EAT SNAIL
word  1  is downey

y: 7  m:  0 
Split: [WHEN I GO TO FRANCE I WILL EAT SNAIL], using: [DOWNEY
]
Result: WHEN I GO TO FRANCE I WILL EAT SNAIL
word  2  is fierce
y: 6  m:  0 
Split: [WHEN I GO TO FRANCE I WILL EAT SNAIL], using: [FIERCE]
Result: WHEN I GO TO FRANCE I WILL EAT SNAIL

CodePudding user response：

in a Textbox it is a vbcrlf not chr(10)

xArrFnd = Split(cFnd, Chr(10))

should be

xArrFnd = Split(cFnd, vbCrLf)

Your split works, but contains for each word still a chr(13)

CodePudding user response：

Alternatively using a regex

Option Explicit

Sub demo()

    Dim dictColor As Object, regex As Object, m, xArrFnd
    Dim rng As Range
    Dim n As Long, i As Long, j As Long, s As String, c As Range
    Dim iColor As Long
    
    Set dictColor = CreateObject("Scripting.Dictionary")
    With dictColor
        .Add "Red", 3
        .Add "Green", 4
        .Add "Blue", 5
        .Add "Cyan", 8
        .Add "Pink", 7
        .Add "Orange", 46
    End With
    
    'Mod2User.Show
    ' color
    iColor = dictColor(CStr(Mod2User.ComboBox1.Value))
    If iColor = 0 Then
        MsgBox "Unknown colour, using RED", vbExclamation
        iColor = 3
    End If
    
    'strings
    s = CStr(Mod2User.TextBox1.Value)
    If Len(s) < 1 Then
        MsgBox "No string", vbExclamation
        Exit Sub
     End If
     
    'xArrFnd - holds array of words to search for
    xArrFnd = Split(s, vbCrLf) 'ASCII 0D0A
    
    Set regex = CreateObject("vbscript.regexp")
    With regex
      .Global = True
      .MultiLine = False
      .IgnoreCase = True
      .Pattern = "(" & Join(xArrFnd, "|") & ")"
      Debug.Print .Pattern
    End With
    
    For Each rng In Selection.Cells
        If regex.test(rng.Value) Then
            Set m = regex.Execute(rng.Value)
            For n = 0 To m.Count - 1
                i = m(n).FirstIndex
                j = Len(m(n))
                rng.Characters(i   1, Length:=j).Font.ColorIndex = iColor
            Next
        End If
    Next
    Unload Mod2User
    
End Sub