CODEWITHSUNDEEP
vbaexcel
Snake
Snake

Reputation: 13

Excel - Copy & paste cells within range when date falls between two user set parameters

I am desperate to make this macro work. I would like a button click to prompt users to enter a beginning and end date, then the macro to copy cells data from B:F in every row where cell A* contains a date within the range starting with row 4. It would then focus to the destination sheet and paste the info into columns H:L starting at row 7.

The source table looks something like this, where rows 1-3 are devoted to sheet info and should be exempt from the macro's analysis

   |   A  |  B  |  C  |  D  |  E  |  F  |
-----------------------------------------
4  | Date |INFO |INFO |INFO |INFO |INFO |
5  | Date |INFO |INFO |INFO |INFO |INFO |
6  | Date |INFO |INFO |INFO |INFO |INFO |
7  | Date |INFO |INFO |INFO |INFO |INFO |

The destination sheet looks like this, with rows 1-6 being used for sheet info.

   |  H  |  I  |  J  |  K  |  L  |
----------------------------------
7  |INFO |INFO |INFO |INFO |INFO | 
8  |INFO |INFO |INFO |INFO |INFO |
9  |INFO |INFO |INFO |INFO |INFO |
10 |INFO |INFO |INFO |INFO |INFO |

And the code I have tried to piecemeal together is 

Sub Copy_Click()

Dim r As Range
Set r = Range("B:F")

startdate = CDate(InputBox("Begining Date"))
enddate = CDate(InputBox("End Date"))

For Each Cell In Sheets("SOURCE").Range("A:A")
    If Cell.Value >= startdate And Cell.Value <= enddate Then
        Sheets("SOURCE").Select
        r.Select
        Selection.Copy

        Sheets("DESTINATION").Select
        ActiveSheet.Range("H:L").Select
        ActiveSheet.Paste
        Sheets("SOURCE").Select
    End If
Next

End Sub

This is obviously not working, and there are no instructions to have it paste to the next available row, nor start on row 7 when pasting to the destination sheet.

Any help would be amazing!

Upvotes: 1

Views: 11018

Answers (1)

Tim Williams
Tim Williams

Reputation: 166366

Untested:

Sub Copy_Click()

    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("SOURCE")
    Set shtDest = Sheets("DESTINATION")

    destRow = 7 'start copying to this row

    startdate = CDate(InputBox("Begining Date"))
    enddate = CDate(InputBox("End Date"))

    'don't scan the entire column...
    Set rng = Application.Intersect(shtSrc.Range("A:A"), shtSrc.UsedRange)

    For Each c In rng.Cells
        If c.Value >= startdate And c.Value <= enddate Then
            'Starting one cell to the right of c,
            '  copy a 5-cell wide block to the other sheet,
            '  pasting it in Col H on row destRow
            c.Offset(0, 1).Resize(1, 5).Copy _
                          shtDest.Cells(destRow, 8)

            destRow = destRow + 1

        End If
    Next

End Sub

Upvotes: 1

Related Questions