PDA

View Full Version : [SOLVED] Store individual cell contents in arrays, match terms and highlight when found



fausto2405
04-21-2015, 02:05 AM
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
04-21-2015, 03:07 AM
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
04-21-2015, 03:49 AM
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
04-22-2015, 06:36 AM
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.

13237

Example using the text from the above cells:
13238

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
04-22-2015, 07:39 AM
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
04-22-2015, 07:52 AM
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.