Highlight specific text in cell

[lockarde]

Hello again all,
I have a macro that builds a calendar and searches sheets for details, placing them within the calendar if dates match. Each calendar day is only one cell, and so if more than one detail needs to go into the calendar day, I have it combine the details, separated by chr(10). I'm trying to get it so it turns any details red if they don't have a corresponding "completion date" but I can't figure out how to have it search through the one cell on the calendar for that detail and highlight only that specific one. It's easy when there is only one detail on that day - I have a nested if statement that checks if only one detail is there, and just changes the range text to red, but I can't get it to go through the string if more than one detail is in the calendar. The code I have is below:

Do
              
            duedate = .Cells(jobfind.Row, c.Column).Value
            francode = .Cells(jobfind.Row, fc.Column).Value
            crtstyle = .Cells(jobfind.Row, cs.Column).Value
            'details are below
            jobdet = francode & " - " & crtstyle
           'next is a holder in case there is more than one detail to go into the calendar day, as jobdet gets overwritten later
            jobdethold = jobdet
            duemos = Month(duedate)
            dueyr = Year(duedate)
            dueday = day(duedate)
            Set cj = .Cells.Find("Comp Date")
            'grabs completion date below
            compdate = .Cells(jobfind.Row, cj.Column).Value
            If duemos = i And dueyr = yr Then
                Set duerng = Sheets("Calendar").Cells.Find(dueday, lookat:=xlWhole)
                Set duerng = duerng.Offset(1, 0)
                If Not duerng.Value2 = "" Then
                    
                    duerng.Value2 = duerng.Value2 & Chr(10) & Chr(10) & jobdet
                    If compdate = "" Then
                        
                      'This is where the text search would go. 
                      'I've found code that formats a range, and code that finds a character in a string, 
                      'but I can't find anything that searches out words within a string
                      'So ideally, code would search for jobdethold within jobdet, and highlight jobdethold red
                    Else

                    End If

                Else
                duerng.Value2 = jobdet
                    If compdate = "" Then
                       duerng.Font.Color = vbRed
                    End If
                End If
                Set jobfind = Sheets(x).Range("A1:A250").Find("Item 1", lookat:=xlWhole, after:=Range(jobfind.Address))
            Else
                
            End If
            next_jf_Address = jobfind.Address
        Loop While jobfind.Address <> first_jf_Address
    End With

 

[starl]

I found your code difficult to read, so instead of trying to modify it, I wrote a Sub you can call. It requires the text to be in the cell before you can color any part of it.
Note that the first argument is a range - the cell where all the text will be placed; the 2nd argument is the text you want to highlight. But be careful - if it's a single word that could be used as part of another word, it could find the wrong word. For example, if you want to highlight the word 'is' in the sentence "This is a test" - the *is* in 'This' will be highlighted.

Sub HighlightWords(ByVal CellWithAllText As Range, ByVal TextToHighlight As String)
Dim FoundText As Long

FoundText = InStr(1, CellWithAllText.Value, TextToHighlight)
If FoundText > 0 Then 'the phrase was found; FoundText is the start of it
    With CellWithAllText
        .Characters(FoundText, Len(TextToHighlight)).Font.Color = RGB(255, 0, 0)
    End With
End If

End Sub

 

[lockarde]

I found your code difficult to read, so instead of trying to modify it, I wrote a Sub you can call. It requires the text to be in the cell before you can color any part of it.
Note that the first argument is a range - the cell where all the text will be placed; the 2nd argument is the text you want to highlight. But be careful - if it's a single word that could be used as part of another word, it could find the wrong word. For example, if you want to highlight the word 'is' in the sentence "This is a test" - the *is* in 'This' will be highlighted.

Sub HighlightWords(ByVal CellWithAllText As Range, ByVal TextToHighlight As String)
Dim FoundText As Long

FoundText = InStr(1, CellWithAllText.Value, TextToHighlight)
If FoundText > 0 Then 'the phrase was found; FoundText is the start of it
    With CellWithAllText
        .Characters(FoundText, Len(TextToHighlight)).Font.Color = RGB(255, 0, 0)
    End With
End If

End Sub

Apologies! It is certainly hard to read without the context of the entire workbook, I tried to comment to give a little background, but not enough :/. Thanks for your response! Your sub works perfectly. I just need to play around with the order of some things. If I step through, I can see it highlighting everything correctly, but if, after it highlights a detail, the loop encounters another detail that goes in that calendar day, it overwrites the highlighted text. For example:
detail 1 has completion date, inserts into calendar day, calendar day.value = detail 1
detail 2 has no completion date, inserts into calendar day, calendar day.value = detail 1+2, runs through your sub, highlights detail 2
detail 3 has completion date, inserts into calendar day, calendar day.value = detail 1+2+3, which overwrites the highlight.

Any thoughts on how to lock that highlight in?

 

[starl]

you'll need to highlight the text after all the details are placed in the cell. It's just the way Excel works - when you update the cell value via code - it replaces the cell value. Unlike manually.
If you record yourself manually highlighting a word within a phrase, you can see how Excel breaks down the highlighting. It specifically will say this part is black, this part is red, this part is black. You need code that duplicates that logic.
I have found that if you call a sub to do the coloring without changing the cell value - the previous color sticks. You just need to provide the start position and the length. So you need to enter all the values, tracking the strings you want to change (or the start position and length), then loop through and color the text

 

[starl]

If you could use special characters (like brackets []) around the text that needs to be red, you wouldn't need to track the strings that need to be red - just look for the brackets and color what's between. But - your results would have brackets in the cell value

 

[lockarde]

you'll need to highlight the text after all the details are placed in the cell. It's just the way Excel works - when you update the cell value via code - it replaces the cell value. Unlike manually.
If you record yourself manually highlighting a word within a phrase, you can see how Excel breaks down the highlighting. It specifically will say this part is black, this part is red, this part is black. You need code that duplicates that logic.
I have found that if you call a sub to do the coloring without changing the cell value - the previous color sticks. You just need to provide the start position and the length. So you need to enter all the values, tracking the strings you want to change (or the start position and length), then loop through and color the text

Gotcha, so my thought is to create an array, and for every detail that goes into a calendar day, and has no completion date, would be placed into that array, and then add a small loop to your sub that runs through the array, searches the entire cell once all details have been added for each item in the array, coloring when it finds a match. Would that work as I imagine?

 

[starl]

Sounds like it would since you aren't editing the actual value.

 

[lockarde]

Sounds like it would since you aren't editing the actual value.

Thanks for your help today, with some messin around I was able to get it to preform exactly as I wanted!

 

[starl]

gratz! can you share the results for the next person with a similar issue?

 

[lockarde]

Below is the working code:
Calendar code that I used and modified can be found here
The first sub finds job details in sheets and copies them to the calendar if the dates match

Sub Find_Info(i As Integer, yr As Integer)

Dim r As Integer, c As Range, crtstyle As String, lastrow As Integer, duerng As Range
Dim francode As String, duemos As Integer, dueyr As Integer, dueday As Integer, fc As Range, cs As Range
Dim shtcnt As Integer, x As Integer, jobfind As Range, lastjob As Range, jobdet As String, xshtname As String
Dim cj As Range, compjob As Integer, jobdethold As String, incjobarr(10) As String, k As Integer
'grabs number of sheets
shtcnt = Sheets.Count
'runs through each sheet, except last
For x = 1 To shtcnt - 1
    With Sheets(x)
        xshtname = Sheets(x).Name
        'finds last job details on sheet, sets lastrow
        Set lastjob = Sheets(x).Cells.Find(what:="Notes:", searchorder:=xlByColumns, searchdirection:=xlPrevious)
        lastrow = lastjob.Row + 1
        'finds info to copy to calendar sheet
        Set c = Sheets(x).Cells.Find("Req Date")
        Set fc = Sheets(x).Cells.Find("Location")
        Set cs = Sheets(x).Cells.Find("Crate Style")
        'finds first job
        Set jobfind = Sheets(x).Range("A1:A250").Find("Item 1", lookat:=xlWhole, LookIn:=xlFormulas)
        first_jf_Address = jobfind.Address
        k = 0
        Do
            'sets variables to copy to calendar
            duedate = .Cells(jobfind.Row, c.Column).Value
            francode = .Cells(jobfind.Row, fc.Column).Value
            crtstyle = .Cells(jobfind.Row, cs.Column).Value
            jobdet = francode & " - " & crtstyle
            'place holder for each new job detail
            jobdethold = jobdet
            'grabs date data
            duemos = Month(duedate)
            dueyr = Year(duedate)
            dueday = day(duedate)
            'finds job completion date
            Set cj = .Cells.Find("Comp Date")
            compdate = .Cells(jobfind.Row, cj.Column).Value
            'if no completion date, saves job details in array to be highlighted red later
            If compdate = "" Then
                incjobarr(k) = jobdethold
                k = k + 1
            End If
            'if date data matches calendar month and year, copies job details to requisite calendar day
            If duemos = i And dueyr = yr Then
                Set duerng = Sheets("Calendar").Cells.Find(dueday, lookat:=xlWhole)
                Set duerng = duerng.Offset(1, 0)
                'if calendar day already has job details, adds new detail to prev, with line spacing
                If Not duerng.Value2 = "" Then
                    duerng.Value2 = duerng.Value2 & Chr(10) & Chr(10) & jobdet
                Else
                    duerng.Value2 = jobdet
                End If
                'finds next job
            Set jobfind = Sheets(x).Range("A1:A250").Find("Item 1", lookat:=xlWhole, after:=Range(jobfind.Address))
            Else
               
            End If
            next_jf_Address = jobfind.Address
        Loop While jobfind.Address <> first_jf_Address
        'if there were any incomplete jobs, runs highlight sub
        If incjobarr(0) <> "" Then
            Call HighlightWords(incjobarr())
        End If
    End With

Next x

End Sub

Next Sub is the highlight sub:

Sub HighlightWords(ByRef incjobarr() As String)
Dim FoundText As Long, k As Integer, r As Integer, c As Integer, textfind As Range
'steps through each cell within calendar, searches for matches within incomplete job array
With Sheets("Calendar")
    k = 0
    For r = 4 To 12 Step 2
        For c = 1 To 7
        k = 0
            Set textfind = .Cells(r, c)
            'runs until it finds empty row in array
            Do Until incjobarr(k) = ""
                FoundText = InStr(1, textfind.Value, incjobarr(k))
                If FoundText > 0 Then 'the phrase was found; FoundText is the start of it
                    With textfind
                        .Characters(FoundText, Len(incjobarr(k))).Font.Color = RGB(255, 0, 0)
                    End With

                End If
            k = k + 1
            Loop
        Next c
    Next r
End With

End Sub