copy dates

[solid]

Can I have the module hereunder modified in three ways (1) Have it copy
the new dated under the last copy date in sheet two (2) The copy
information must sent to sheet2 stating form a3 downward and (3) I need
to copy information from about ten worksheet sheet in order of date
to worksheet 2

Sub FindDates()
On Error GoTo errorHandler
Dim startDate As String
Dim endDate As String
Dim startRow As Integer
Dim endRow As Integer
startDate = InputBox("Enter the Start Date: (mm/dd/yyyy)")
If startDate = "" Then End
endDate = InputBox("Enter the End Date: (mm/dd/yyyy)")
If endDate = "" Then End
startDate = Format(startDate, "mm/dd/yyyy")
endDate = Format(endDate, "mm/dd/yyyy")
startRow = Worksheets("sheet1").Columns("a").Find(startDate, _
LookIn:=xlValues, lookat:=xlWhole).Row
endRow = Worksheets("sheet1").Columns("a").Find(endDate, _
LookIn:=xlValues, lookat:=xlWhole).Row
Worksheets("sheet1").Range("A" & startRow & ":A" & endRow) _
.Resize(, 4).Copy Destination:= _
Worksheets("sheet2").Range("a1")
End
errorHandler:
MsgBox "There has been an error: " & Error() & Chr(13) _
& "Ending Sub.......Please try again", 48
End Sub

 

[Tom Ogilvy]

Sub FindDates()
On Error GoTo errorHandler
Dim startDate As String
Dim endDate As String
Dim startRow As Integer
Dim endRow As Integer
Dim rng as Range
Dim v as Variant
v = Array("Sheet1", "Sheet3", "Sheet4", _
"Sheet5", "Data", "Day6", . . . )
startDate = InputBox("Enter the Start Date: (mm/dd/yyyy)")
If startDate = "" Then exit sub
endDate = InputBox("Enter the End Date: (mm/dd/yyyy)")
If endDate = "" Then exit sub
startDate = Format(startDate, "mm/dd/yyyy")
endDate = Format(endDate, "mm/dd/yyyy")
for i = lbound(v) to ubound(v)
sName = v(i)
startRow = 0
endRow = 0
On Error Resume Next
startRow = Worksheets(sName).Columns("a").Find(startDate, _
LookIn:=xlValues, lookat:=xlWhole).Row
endRow = Worksheets(sName).Columns("a").Find(endDate, _
LookIn:=xlValues, lookat:=xlWhole).Row
On Error goto ErrHandler
if startRow <> 0 and endRow <> 0 then
set rng = Worksheets("Sheet2").Cells(rows.count,1).End(xlup)
if rng.row < 3 then
set rng = Worksheets("Sheet2").Range("A3")
else
set rng = rng.offset(1,0)
end if
Worksheets(sName).Range("A" & startRow & ":A" & endRow) _
.Resize(, 4).Copy Destination:= rng
End if
Next i
exit sub
ErrorHandler:
MsgBox "There has been an error: " & Error() & Chr(13) _
& "Ending Sub.......Please try again", 48
End Sub