VBA Copy Paste Range based on Date (Today's date and specific)

[gcefaloni]

Hi guys,

I have the current macro that I patched up together from different sources. It works relatively well but I would like to modify it to make it more convenient.

Sub Copy_Range()


    Dim startdate As Date, enddate As Date
    Dim rng As Range, destRow As Long
    Dim shtSrc As Worksheet, shtDest As Worksheet
    Dim c As Range


    Set shtSrc = Sheets("BLOTTER Core+")
    Set shtDest = Sheets("TRADE FILE")


    destRow = 2 'start copying to this row


    startdate = CDate(InputBox("Begining Date"))
    enddate = CDate(InputBox("End Date"))
    
    shtDest.Range("S2:AZ1000").Clear
    
    'don't scan the entire column...
    Set rng = Application.Intersect(shtSrc.Range("C:C"), shtSrc.UsedRange)


    For Each c In rng.Cells
        If c.Value = startdate And c.Value <= startdate Then
            'Starting 2 cells to the left of c,
            '  copy a 20-cell wide block to the other sheet,
            '  pasting it in Col S (19) on row destRow
            c.Offset(0, -2).Resize(1, 20).Copy _
                          shtDest.Cells(destRow, 19)


            destRow = destRow + 1


        End If
    Next


End Sub

So instead of manually entering a range of dates to copy from (startdate and enddate), I would like to simply have the code check the range for Today's date and automatically copying the corresponding rows (that have today's date) to the destination. What should I modify in the code in order to do that?

Additionally, I would like to simply type in a specific date (from historical data points) and copy the same corresponding ranges but for that date (which is not today). So that would require a Cdate(InputBox("Specify Date")), but when I do that, it copies the entire range of all dates instead of the specific rows with only that date. I'm not sure why. What should I modify in the code in order to get the specify date to work?

Just to be clear, what I'm trying to do is simply scan a range of dates (in column C) for today's date and to copy the corresponding rows with today's date from column A to U (block of 20 cells in the code above) to a destination sheet into the range S2:AMx.

Thank you for your help!

 

[Richard U]

Sub Copy_Range()


    Dim startdate As Date
    Dim enddate As Date
    Dim rng As Range
    Dim destRow As Long
    Dim shtSrc As Worksheet
    Dim shtDest As Worksheet
    Dim MyCell As Range


    Set shtSrc = Sheets("BLOTTER Core+")
    Set shtDest = Sheets("TRADE FILE")


    destRow = 2 'start copying to this row


    'startdate = CDate(InputBox("Begining Date"))
    'enddate = CDate(InputBox("End Date"))
    
    shtDest.Range("S2:AZ1000").Clear
    
    'don't scan the entire column...
    Set rng = Application.Intersect(shtSrc.Range("C:C"), shtSrc.UsedRange)


    For Each c In rng.Cells
        If MyCell.Value = Format(Now(), "Short date") Then
            'Starting 2 cells to the left of c,
            '  copy a 20-cell wide block to the other sheet,
            '  pasting it in Col S (19) on row destRow
            MyCell.Offset(0, -2).Resize(1, 20).Copy _
                          shtDest.Cells(destRow, 19)


            destRow = destRow + 1


        End If
    Next


End Sub

 

[gcefaloni]

Sub Copy_Range()


    Dim startdate As Date
    Dim enddate As Date
    Dim rng As Range
    Dim destRow As Long
    Dim shtSrc As Worksheet
    Dim shtDest As Worksheet
    Dim MyCell As Range


    Set shtSrc = Sheets("BLOTTER Core+")
    Set shtDest = Sheets("TRADE FILE")


    destRow = 2 'start copying to this row


    'startdate = CDate(InputBox("Begining Date"))
    'enddate = CDate(InputBox("End Date"))
    
    shtDest.Range("S2:AZ1000").Clear
    
    'don't scan the entire column...
    Set rng = Application.Intersect(shtSrc.Range("C:C"), shtSrc.UsedRange)


    For Each c In rng.Cells
        If MyCell.Value = Format(Now(), "Short date") Then
            'Starting 2 cells to the left of c,
            '  copy a 20-cell wide block to the other sheet,
            '  pasting it in Col S (19) on row destRow
            MyCell.Offset(0, -2).Resize(1, 20).Copy _
                          shtDest.Cells(destRow, 19)


            destRow = destRow + 1


        End If
    Next


End Sub

Thank you Richard for trying to help. If I use your code, I get the Run-time error "Object variable or with block variable not set" and the line "If MyCell.Value = Format(Now(), "Short date") Then" is highlighted when I hit debug. Also, when I change "For Each c In rng.Cells" for "For Each MyCell In rng.Cells", there are not bugs but also no copying happening.

 

[Richard U]

Sorry about that, I made a few typos

Sub Copy_Range()


    Dim startdate As Date
    Dim enddate As Date
    Dim rng As Range
    Dim destRow As Long
    Dim shtSrc As Worksheet
    Dim shtDest As Worksheet
    Dim MyCell As Range


    Set shtSrc = Sheets("BLOTTER Core+")
    Set shtDest = Sheets("TRADE FILE")


    destRow = 2 'start copying to this row


    'startdate = CDate(InputBox("Begining Date"))
    'enddate = CDate(InputBox("End Date"))
    
    shtDest.Range("S2:AZ1000").Clear
    
    'don't scan the entire column...
    Set rng = Application.Intersect(shtSrc.Range("C:C"), shtSrc.UsedRange)


    For Each MyCell In rng.Cells
        If Format(MyCell.Value, "Short date") = Format(Now(), "Short date") Then
            'Starting 2 cells to the left of c,
            '  copy a 20-cell wide block to the other sheet,
            '  pasting it in Col S (19) on row destRow
            MyCell.Offset(0, -2).Resize(1, 20).Copy _
                          shtDest.Cells(destRow, 19)


            destRow = destRow + 1


        End If
    Next MyCell


End Sub

 

[gcefaloni]

Thanks a lot Richard. Works perfectly. I'm not sure I understand the difference between that and what I had tried before but it works very well. It is very appreciated. Thank you