Archive of Mr Excel Message Board

Give this a try. It assumes that Date is in column C and sheet code names are sheet1 and sheet2

Sub MoveRows()
On Error GoTo ErrHandler

Dim dStartDate As Date
Dim dEndDate As Date

'Collect Start & End Dates
dStartDate = CDate(InputBox("Enter Start Date", "Valid Format - mm/dd/yyyy"))
dEndDate = CDate(InputBox("Enter End Date", "Valid Format - mm/dd/yyyy"))


'Find Dates Between Start Date & End Date and move to sheet 2
Sheet1.Activate

'Assume column C contains the dates
Application.Range("C1").Select

'Look at every row in column C until it finds an empty cell.
Do Until ActiveCell.Value = vbNullString

'Verify that the date is between the Start Date & End Date
If ActiveCell.Value > dStartDate And ActiveCell.Value < dEndDate Then

'If it is, cut the entire row
ActiveCell.EntireRow.Cut

'Activate sheet 2
Sheet2.Activate

'Find the first blank row on sheet 2
Application.Range("A1").Select
Do Until ActiveCell.Value = vbNullString
ActiveCell.Offset(1, 0).Select
Loop

'Paste the row from sheet 1
ActiveSheet.Paste

'Return to sheet 1
Sheet1.Activate

'Delete the blank row
ActiveCell.EntireRow.Delete

'Move back down up row. The delete pushed us down one to many rows
ActiveCell.Offset(-1, 0).Select
End If

'Move down one row
ActiveCell.Offset(1, 0).Select
Loop

ExitHandler:
Exit Sub

ErrHandler:
Dim sMessage As String

sMessage = "An error has occured. This Macro will end"
sMessage = sMessage & vbCrLf
sMessage = sMessage & "Error Number - "
sMessage = sMessage & Err.Number
sMessage = sMessage & vbCrLf
sMessage = sMessage & "Error Description - "
sMessage = sMessage & Err.Description

MsgBox sMessage, vbCritical, "Macro Error"

Resume ExitHandler

End Sub

Hope this helps.

Jerid

PS. You can send the file to dvlavianos@cosmote.gr

'Collect Start & End Dates dStartDate = CDate(InputBox("Enter Start Date", "Valid Format - mm/dd/yyyy")) dEndDate = CDate(InputBox("Enter End Date", "Valid Format - mm/dd/yyyy"))