Add-in additional word in cell

I need Experts help to add additional function in the attached script. Whenever cell at column D has “Match” word, the correspondent cell at Week sheet need to add-in with word“[Test Line]” in red font (8 font size). The script is actually being used to copy data from Column C to Week sheets based on Date (Column A-Data sheet) and Time (Column B – Data sheet) with date (Row2-Week sheet) and Time (Column A). I have manually add-in few data at Week1 sheet for Experts to get better view.  Hope Experts could help.

Sub CopyDataToWeek()
Dim WS As Worksheet, WSt As Worksheet
Dim wb As Workbook
Dim LookForDate As Date, LookForTime As String
Dim DateFoundCol As Long, MaxRow As Long, i As Long, J As Long
Dim Cell As Range, FindDate As Range, FindTime As Range

Set wb = ActiveWorkbook
Set WS = Sheets("Data")
MaxRow = WS.Rows(WS.Rows.Count).End(xlUp).Row

For Each Cell In WS.Range("D6:D" & MaxRow) '.SpecialCells(xlCellTypeConstants)
    If Len(Cell.Offset(, -3)) > 5 Then
                 If Int(CDate(Cell.Offset(, -3))) >= CDate(WS.Range("G2")) And Int(CDate(Cell.Offset(, -3))) <= CDate(WS.Cells.Range("H2")) Then
            LookForDate = CDate(Cell.Offset(, -3))
            For Each WSt In wb.Worksheets
                If UCase(Left(WSt.Name, 4)) = "WEEK" Then
                    Set FindDate = WSt.Range("2:2").Find(What:=Format(LookForDate, "d/m/yyyy"), LookIn:=xlValues, LookAt:=xlWhole)
                    If Not FindDate Is Nothing Then
                        'Copy the data to the selected Column
                        DateFoundCol = FindDate.Column
                        i = Cell.Row
                        If WS.Cells(i, 3) <> "" Then
                            LookForTime = Format(WS.Cells(i, 2), "h:mm")
                            Set FindTime = WSt.Range("A:A").Find(LookForTime, LookIn:=xlValues, LookAt:=xlWhole)
                            If Not FindTime Is Nothing Then
                                WSt.Cells(FindTime.Row, DateFoundCol) = WS.Cells(i, 3)
                                If WS.Cells(i, 4) = "Match" Then WSt.Cells(FindTime.Row, DateFoundCol).Interior.ColorIndex = 27
                                If WS.Cells(i, 4) = "Type" Then WSt.Cells(FindTime.Row, DateFoundCol).Interior.ColorIndex = 3
                                J = J + 1
                            End If
                        End If
                    End If
                End If
            Next WSt
        End If
    End If
Next Cell

MsgBox ("Total of " & J & " Titles has been copied successfully to their coresponding weeks")
End Sub

Select allOpen in new window

Copy-Data--2-.xls