1

I have an Excel workbook that has ~15 sheets. I'm looking for a way to copy rows to a new sheet based on the date range in column K.

Example:

Sheet 1: Date range (1/1/15 - 1/1/18) -> Copy all rows within time range to Sheet 4

Sheet 2: Date range (1/1/15 - 1/1/18) -> Copy all rows within time range to Sheet 5

Sheet 3: Date range (1/1/15 - 1/1/18) -> Copy all rows within time range to Sheet 6

etc.

Code which does the job one sheet at a time, but I would like it to work on one go:

Sub Date_Sample() Application.ScreenUpdating = False On Error GoTo M Dim i As Long Dim ans As Date Dim anss As Date Dim Lastrow As Long Dim Lastrowa As Long ans = InputBox("Start Date Is") anss = InputBox("End Date Is") Lastrowa = Sheets("Sheet1").Cells(Rows.Count, "K").End(xlUp).Row Lastrowb = Sheets("Sheet4").Cells(Rows.Count, "K").End(xlUp).Row + 1 For i = 1 To Lastrowa If Cells(i, "K").Value >= ans And Cells(i, "K").Value <= anss Then Rows(i).Copy Destination:=Sheets("Sheet4").Rows(Lastrowb) Lastrowb = Lastrowb + 1 Rows(i).EntireRow.Delete i = i - 1 End If Next i Application.ScreenUpdating = True Exit Sub M: MsgBox "Wrong Date" Application.ScreenUpdating = True End Sub

I tried adding another For statement for the other sheets but it did not work.

Improve this question
1
  • 1) Use AutoFilter to get the data. 2) Loop through each worksheet. 3) Use Select Case on the worksheet name to determine on which worksheet the data will be copied . Commented Jan 7, 2019 at 21:00

1 Answer 1

Reset to default
1

Array of Sheets

Added variables:

  • j - Sheets Counter
  • str1 - List of sheets to copy from
  • str2 - List of sheets to copy to
  • vnt1 - Array of sheets to copy from
  • vnt2 - Array of sheets to copy to

The Code

Sub Date_Sample() Application.ScreenUpdating = False On Error GoTo M Const str1 As String = "Sheet1,Sheet2,Sheet3" Const str2 As String = "Sheet4,Sheet5,Sheet6" Dim vnt1 As Variant Dim vnt2 As Variant Dim i As Long Dim j As Integer Dim ans As Date Dim anss As Date Dim Lastrow As Long Dim Lastrowa As Long ans = InputBox("Start Date Is") anss = InputBox("End Date Is") vnt1 = Split(str1, ",") vnt2 = Split(str2, ",") For j = 0 To UBound(vnt1) Lastrowa = Sheets(vnt1(j)).Cells(Rows.Count, "K").End(xlUp).Row Lastrowb = Sheets(vnt2(j)).Cells(Rows.Count, "K").End(xlUp).Row + 1 For i = 1 To Lastrowa With Sheets(vnt1(j)) If .Cells(i, "K").Value >= ans _ And .Cells(i, "K").Value <= anss Then .Rows(i).Copy Destination:=Sheets(vnt2(j)).Rows(Lastrowb) Lastrowb = Lastrowb + 1 .Rows(i).EntireRow.Delete i = i - 1 End If End With Next i Next j Application.ScreenUpdating = True Exit Sub M: MsgBox "Wrong Date" Application.ScreenUpdating = True End Sub
Improve this answer
Sign up to request clarification or add additional context in comments.

3 Comments

This works great with one exception. Sheet1 does not copy over to Sheet4. The codes seems to start with Sheet2.
@Searshore: sorry, Just change For j = 1 to ... to For j=0 to.... these arrays are 0-based.
Perfect! Thank you so much! Still learning about Arrays. I appreciate it very much!

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.