Multi color text in single cell - vb macro

[ebehen]

I am using a macro and worksheet, found on the form and changing it to fit my needs, that takes a list of dates and creates a calender. There are multiple events on a single date (or Cell) I want to format the text of individual events to be color coded based on a value. Here is the code I am working with.

Private Sub ShowSpecialDates()
Dim I As Integer
Dim TestDate As Date
Dim TestCell As Range
Dim HRange As Range
Dim d As Integer
Dim addtext As String
Dim CellLen As Integer
Dim Newlen As Integer

Set HRange = Range(Range("HDateStart"), Range("HDateStart")(65000).End(xlUp)(1, 1))

For I = 1 To 42
    d = Val(Cal(I - 1))
    If d > 0 Then
        TestDate = DateSerial(CurrYear, CurrMonth, d)
        For Each TestCell In HRange
            If TestCell.Value = TestDate Then
                addtext = TestCell(1, 3).Value
                Newlen = Len(TestCell(1, 3))
                CellLen = Len(Cal(I - 1))
                Select Case TestCell(1, 2).Value
                    Case "H"
                        If Range("ShowHoliday").Value = True Then
                            Cal(I - 1) = Cal(I - 1) & Chr(10) & addtext
                             Range("CalRng")(I).Characters(CellLen, Newlen).Font.ColorIndex = 3
                            If Range("MultItems").Value = False Then
                                Exit For
                            End If
                        End If
                    Case "B"
                        If Range("ShowBirthday").Value = True Then
                            Cal(I - 1) = Cal(I - 1) & Chr(10) & addtext
                            Range("CalRng")(I).Characters(CellLen, Newlen).Font.ColorIndex = 4
                            If Range("MultItems").Value = False Then
                                Exit For
                            End If
                        End If
                    Case "O"
                        If Range("ShowHoliday").Value = True Then
                            Cal(I - 1) = Cal(I - 1) & Chr(10) & addtext
                            Range("CalRng")(I).Characters(CellLen, Newlen).Font.ColorIndex = 5
                            If Range("MultItems").Value = False Then
                                Exit For
                            End If
                        End If
                    Case Else
                End Select
            End If
        Next TestCell

    End If
Next I
End Sub

But this colors all the text in the cell based on the last event. Not sure where i went wrong. or if someone has a better way of doing this please let me know.

Thanks in advance.

 

[pbornemeier]

Without seeing how you have your named ranges and data setup it is hard to understand exactly what your code is doing, but I think I have it.

What is the relationship between Cal(I-1) and Range("CalRng")(I) you are testing on the first one and setting colors on the second.

For immediate troubleshooting, I would add a debug.print statement after each of these:

Range("CalRng")(I).Characters(CellLen, Newlen).Font.ColorIndex = x
Debug.Print TestCell(1, 2).Value, I, CellLen, Newlen

and step through the code to check to see if you are getting the values you expect.

You might also want to change these lines:

Range("CalRng")(I).Characters(CellLen + 1, Newlen).Font.ColorIndex = x

so you are coloring from the start of the added text