Store individual cell contents in arrays, match terms and highlight when found

[fausto2405]

Hi everyone in struggling quite a bit with this task and its getting more complicated in vba so please any help would be really appreciated.

I have two columns, Column E contains texts from drug pamphlets describing what they are used for, essentially a list of diseases in between some random text. Column D contains the list of diseases for each corresponding cell in Column E. I need the text from cells E(x) to be formated wherever the diseases from D(x) appear.

I've attached a sample workbook with what the data looks like and what it should look like with a working macro.

I've gotten as far as having a macro that uses an array (stored manually in vba code) and searches for those terms in the selected range and formats the cells in Column E whenever they are found, and it works. The problem is that with this code i'd have to have one million plus values to store in this array and when i try paste that in vba...it crashes (i know but i am a noob and anything goes at this point).

This is the code below

Option Compare Text
Sub colorText()


Dim cl As Range
Dim startPos As Integer
Dim totalLen As Integer
Dim searchText As String
Dim endPos As Integer
Dim testPos As Integer

' add number of aliases in array.
Dim sArray(1 To 3) As String
Dim i As Long

sArray(1) = "Value1"
sArray(2) = "Value2"
sArray(3) = "Value3"


' specify text to search.

For i = 1 To 3
searchText = sArray(i)


' loop trough all cells in selection/range
For Each cl In Selection

  totalLen = Len(searchText)
  startPos = InStr(cl, searchText)
  testPos = 0

  Do While startPos > testPos
    With cl.Characters(startPos, totalLen).Font
      .FontStyle = "Bold"
      .ColorIndex = 3
    End With

    endPos = startPos + totalLen
    testPos = testPos + endPos
    startPos = InStr(testPos, cl, searchText, vbTextCompare)
  Loop

Next cl

Next i


End Sub

I need to fix the above code so that instead of having one array to all the cells in Column E, it should for eg.

Make an array for cell D2 with each line of text within the cell as an array value and match that against E2.

Then make a new array for cell D3 and match that against E3...and so on. How should i change the above code to make it work in that way? Thanks in advance.

[fausto2405]

Wow i didnt think id be capable of it but i got it working!

modified the code as follows:

Option Compare Text


Sub colorTextWIP()




Dim cl As Range
Dim startPos As Integer
Dim totalLen As Integer
Dim searchText As String
Dim endPos As Integer
Dim testPos As Integer


' define array.
Dim sArray() As String
Dim i As Long




' loop trough all cells in selection/range
For Each cl In Selection


' create array with cells left of selection.


sArray = Split(cl.Offset(0, -1).Value, "###")
For i = LBound(sArray) To UBound(sArray)
searchText = sArray(i)


' match text.

  totalLen = Len(searchText)
  startPos = InStr(cl, searchText)
  testPos = 0


  Do While startPos > testPos
    With cl.Characters(startPos, totalLen).Font
      .FontStyle = "Bold"
      .ColorIndex = 3
    End With


    endPos = startPos + totalLen
    testPos = testPos + endPos
    startPos = InStr(testPos, cl, searchText, vbTextCompare)
  Loop


Next i


Next cl


End Sub

yay to me! however i have to convert the delimiter in cells D(x) from new line (ctrl+j) to random characters (###) in order to get the split function to work.

[fausto2405]

The text in column D matches the text in column E even if the words are not the same... "Illness" in d2 would highlight in red a portion of the word "Illnesses".

[fausto2405]

BUG: For some reason the macro wont find ALL instances of matching substrings in the cells. I've attached a picture to show the problem. Note that the circled terms are identical to previous ones matched in colored text.
Code has been slightly altered in order to alternate colors between matching terms. All integer values have also been converted to long to stop an error.

Capture.JPG

Example using the text from the above cells:
Capture2.JPG

The problem persists on previous versions of the code ive pasted above. This is the latest iteration fyi.

Sub colorTextWIP()



Dim cl As Range
Dim startPos As Long
Dim totalLen As Long
Dim searchText As String
Dim endPos As Long
Dim testPos As Long


' define array.
Dim sArray() As String
Dim i As Long
Dim c As Long


c = 0


' loop trough all cells in selection/range
For Each cl In Selection


' create array with cells left of selection.


sArray = Split(cl.Offset(0, -1).Value, "###")
For i = LBound(sArray) To UBound(sArray)
searchText = sArray(i)


  totalLen = Len(searchText)
  startPos = InStr(cl, searchText)
  testPos = 0


  Do While startPos > testPos
  c = c + 1
  
    With cl.Characters(startPos, totalLen).Font
      .FontStyle = "Bold"
      
      If IsOdd(c) Then
      .ColorIndex = 3
    Else: .ColorIndex = 4
    End If
    
    
    End With


    endPos = startPos + totalLen
    testPos = testPos + endPos
    startPos = InStr(testPos, cl, searchText, vbTextCompare)
  Loop


Next i


c = 0


Next cl






End Sub

[Paul_Hossler]

Not sure I understand everything you're trying to do (the ### in Col's A, B, and C for example), but I think there were some simplifications that would make it easier

Option Explicit
Sub ColorText_2()
     
    Dim ws As Worksheet
    Dim rDiseases As Range, rCell As Range
    Dim avDiseases As Variant
    Dim iDisease As Long, iMatchStart As Long, iColor As Long
    
    
    
    Set ws = Worksheets("Task")
    Set rDiseases = Range(ws.Cells(2, 4), ws.Cells(ws.Rows.Count, 4).End(xlUp))
     
    For Each rCell In rDiseases.Cells
        
        iColor = vbRed
        
        avDiseases = Split(rCell.Value, vbLf)
             
        For iDisease = LBound(avDiseases) To UBound(avDiseases)
            
            iMatchStart = 1
            
            Do While iMatchStart > 0
                iMatchStart = InStr(iMatchStart, rCell.Offset(0, 1).Value, avDiseases(iDisease), vbTextCompare)
                If iMatchStart > 0 Then
                    rCell.Offset(0, 1).Characters(iMatchStart, Len(avDiseases(iDisease))).Font.Color = iColor
                    iColor = IIf(iColor = vbRed, vbGreen, vbRed)
                    
                    iMatchStart = iMatchStart + Len(avDiseases(iDisease))
                End If
            
            Loop
     
        Next iDisease
     
     Next
     
     
End Sub

[fausto2405]

I forgot about columns a b and c, i was just trying to hide the data, sorry for the confusion. Your method works a charm thanks a lot for your effort. Ill let you know if any bugs show up. For your information this was the first time i did any real work in excel vba any this solution instantly relieved my headache. Thanks again.