Copy Data based on Date Selection

Hi Experts,

I would like to request Experts help to add additional function in the attached script. The current script able to copy all data from Column C (Data sheet) to Week1 to Week5 sheets according to Date and Time (Column A - Data Sheet).

The additional that required in this script Is to copy only the selected data based on the Start Date and End Date at cell G2 and H2 to the relevant Week Sheet. E.g. if date range 8-Nov to 14-Nov were selected, therefore only  Week2 sheet will be updated (8/11/2011 - 14/11/2011). Other data remain unchanged.  Attached as well the workbook for Experts perusal. Hope Experts will help me create this new feature.

 

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("D5:D" & MaxRow).SpecialCells(xlCellTypeBlanks)
    If Len(Cell.Offset(, -3)) > 5 Then
        LookForDate = 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 + 2
                    Do
                        If ws.Cells(I, 3) <> "" Then
                            LookForTime = Format(ws.Cells(I, 1), "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, 2) = "TypeA" Then WSt.Cells(FindTime.Row, DateFoundCol).Interior.ColorIndex = 6
                                If ws.Cells(I, 2) = "TypeB" Then WSt.Cells(FindTime.Row, DateFoundCol).Interior.ColorIndex = 33
                                J = J + 1
                            End If
                        End If
                        I = I + 1
                    Loop Until ws.Cells(I, 1) = ""
                    Exit For
                End If
            End If
        Next WSt
    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-Date.xls