troubleshooting Question

Add-in additional word in cell

Avatar of Billa7
Billa7 asked on
Microsoft Excel
4 Comments1 Solution166 ViewsLast Modified:
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
Copy-Data--2-.xls
Join the community to see this answer!
Join our exclusive community to see this answer & millions of others.
Unlock 1 Answer and 4 Comments.
Join the Community
Learn from the best

Network and collaborate with thousands of CTOs, CISOs, and IT Pros rooting for you and your success.

Andrew Hancock - VMware vExpert
See if this solution works for you by signing up for a 7 day free trial.
Unlock 1 Answer and 4 Comments.
Try for 7 days

”The time we save is the biggest benefit of E-E to our team. What could take multiple guys 2 hours or more each to find is accessed in around 15 minutes on Experts Exchange.

-Mike Kapnisakis, Warner Bros