How to Select Range based on dates in cells

[Mike]

Two workbooks are identical with respect to worksheets, row & columns
layouts, etc. Data for 2003 and 2004 is located in range B4:AJ305 of
"Sheet 3" of WkBk "2004" and range B4:B305 contains only dates (format
M/D/YYYY). "Sheet 3" of WkBk "2005" contains no data in range
B4:AJ305, but is otherwise identical in terms of row & column layout.

I need VBA code that will:

1) Sort the rows in range B4:AJ305 of "Sheet 3" of WkBk "2004" in
ascending order based on the date values in column B (range is
B4:B305), then

2) Select only those rows in "Sheet 3" of WkBk "2004" where the date
value in range B4:B305 is greater than 12/31/2003 (2004 dates) and
then,

3) copy values, formats, and validations of that range (the rows with
2004 data) into range B4:AJ305 of "Sheet 3" of WkSht "2005".

I read posts by Tom Olgivy's where he recommends use of
"Range("A2").Value = Range("A1").Value" as a way to simplify Copy and
PasteSpecial routines, but do not know how to tweak that approach to
set the values in a range in one WkBk equal to a range in a different
WkBk.

I managed to piece together the following code to almost do what I
need. I suspect the code is neither elegant nor as efficient as it
could be. Any suggetions/feedback will be greatly appreciated.

Mike Taylor

---------------------------------------------------------------------------

Sub CopyBasedOnDates()

Dim wkbDest As Workbook
Dim wksDest As Worksheet
Dim wksSrc As Worksheet
Dim strMyDate As String
Dim rngDateCol As Range
Dim rngCopy As Range
Dim Lrow As Long
Dim lNextRow As Long

strMyDate = InputBox("Enter a date")

'Exit if a date was not entered
If Not IsDate(strMyDate) Then
Exit Sub
End If

'The active sheet is the source
Set wksSrc = ActiveSheet
wksSrc.Activate
Range("B4").Select
'Create a new workbook to store the results
Set wkbDest = Workbooks.Add(1)
'Set the first worksheet to hold the results
Set wksDest = wkbDest.Worksheets(1)

'Reset this variable
lNextRow = 0

'Set a reference to the dates column. Adjust this as needed.
With wksSrc
Set rngDateCol = .Range("B4:B" & _
..Range("B" & .Rows.Count).End(xlUp).Row)
End With

'Loop through each cell (row) in the dates column
For Lrow = 1 To rngDateCol.Rows.Count

'If the date in the dates column matches the date entered...
If rngDateCol(Lrow).Value > DateValue(strMyDate) Then

'...store the range of the source worksheet. This will be
'copied over to the new (destination) worksheet
With wksSrc
Set rngCopy = .Range(.Cells(rngDateCol(Lrow).Row, "A"), _
..Cells(rngDateCol(Lrow).Row, "AQ"))
End With

'...increment the row counter for the destination worksheet
lNextRow = lNextRow + 1

'..."paste" the stored range into the destination worksheet
wksDest.Cells(lNextRow, "A"). _
Resize(, rngCopy.Columns.Count).Value = rngCopy.Value

End If

Next

wksSrc.Activate
Rows("1:3").Select
Selection.Copy
wksDest.Activate
Rows("1:1").Select
Selection.Insert Shift:=xlDown
Selection.PasteSpecial Paste:=8, Operation:=xlNone,
SkipBlanks:=False _
, Transpose:=False

wksSrc.Activate
Columns("A:A").Select
Application.CutCopyMode = False
Selection.Copy
wksDest.Activate
Columns("A:A").Select
'Selection.Insert Shift:=xlToRight
ActiveSheet.Paste

wksSrc.Activate
ActiveSheet.Range("B4:AJ4").Select
'Rows("4:4").Select
Application.CutCopyMode = False
Selection.Copy
wksDest.Activate
ActiveSheet.Range("B4:AJ305").Select
'Paste:=8 means paste column widths
Selection.PasteSpecial Paste:=8, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
'Paste:=6 means paste validation
Selection.PasteSpecial Paste:=6, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False

Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:=False

Selection.Locked = False
Selection.FormulaHidden = False

Range("B4").Select

'Show the SaveAs dialog
wkbDest.Activate
Application.Dialogs(xlDialogSaveAs).Show "2005 DTR 5.0 test.xls"

Set wkbDest = Nothing
Set wksDest = Nothing
Set wksSrc = Nothing

End Sub

 

[Guest]

Try something like:

Option Explicit

Sub TestCopyTo2005()
Dim rDest As Range
Dim rSource As Range


With Workbooks("2004").Sheets("Sheet 3").Range("B4:AJ305")
.Select
.Sort Key1:=Range("B4"), _
Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

.Find(What:="*/*/04", After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False).Activate
End With
Set rSource = Range(ActiveCell, Range("AJ305"))
Set rDest = Workbooks("2005").Sheets("Sheet 3").Range("B4")
rSource.Copy rDest
End Sub