Search on Date Range - Copy Row with matching Date 1

[Airbisk]

Hi,

I found the program below and have amended it to suit the needs. The needs have changed. Currently the program would look at the date entered in F15 and pull into Search Results all the rows where that date appears in Column I of the Site Print Worksheet.

Now a Date to field has been added in F17. Would you be able to help with some guidance with incorporating a way of looking at the Date From and Date To and pulling back the rows where a date within the range appears in Column I.

Many Thanks in Advance


Sub fohdatemoving()
Dim c As Range, d As Range

If Range("F15") = "" Then

MsgBox "Please Select a FOH Date From"


ElseIf Range("F17") = "" Then

MsgBox "Please Select a FOH Date To"

Else

Worksheets("Search Results").Activate
Application.ScreenUpdating = False
Cells.Select
Selection.ClearContents
Range("A1").Select

Sheets("Site Print").Select
Rows("1:1").Select
Selection.Copy
Sheets("Search Results").Select
Rows("1:1").Select
ActiveSheet.Paste

For Each c In Worksheets("Site Print").Range("I1:I8000")
For Each d In Worksheets("Criteria").Range("F15")
If c = d Then
c.EntireRow.Copy Worksheets("Search Results").Range("A65536").End(xlUp).Offset(1, 0)
Exit For
End If
Next
Next

Cells.Select
Cells.EntireColumn.AutoFit
Range("D3").Select
Columns("D").ColumnWidth = 48.71
Columns("O:O").ColumnWidth = 38.86
Columns("A:A").ColumnWidth = 8.29
Rows("1:1").RowHeight = 15.75

Range("A1").Select

End If

End Sub

 

[xlbo]

Use autofilter with 2 criteria >=F15 and <=F17 then copy visible cells to new sheet for formatting

Rgds, Geoff

We could learn a lot from crayons. Some are sharp, some are pretty and some are dull. Some have weird names and all are different colours but they all live in the same box.

Please read FAQ222-2244 before you ask a question

 

[SkipVought]

hi,

    Dim c As Range, [b]dFrom As Date, dThru As Date
    [/b]
    If Range("F15") = "" Then
    
        MsgBox "Please Select a FOH Date From"
        
        
    ElseIf Range("F17") = "" Then
    
        MsgBox "Please Select a FOH Date To"
        
    Else
    [b]
        dFrom = Range("F15").Value
        dThru = Range("F17").Value
        [/b]
        Worksheets("Search Results").Activate
        Application.ScreenUpdating = False
        Cells.Select
        Selection.ClearContents
        Range("A1").Select
        
        Sheets("Site Print").Select
        Rows("1:1").Select
        Selection.Copy
        Sheets("Search Results").Select
        Rows("1:1").Select
        ActiveSheet.Paste
        
        For Each c In Worksheets("Site Print").Range("I1:I8000")
            For Each d In Worksheets("Criteria").Range("F15")[b]
                If c.Value >= dFrom And c.Value <= dThru Then[/b]

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}

 

[Airbisk]

Thanks guys, have used Skip's method with success.

Kind Regards

 

[xlbo]

Skip - I never would've thought you'd facilitate a looping solution when a more efficient way was possible - shocked I am ;-)

dFrom = Range("F15").Value
dThru = Range("F17").Value


With Worksheets("Site Print").Range("A1:Z8000")

  .autofilter field:=9 Criteria1:=">=" & dFrom, Operator:=xlAnd, Criteria2:="<=" & dThru

  .specialcells(xlcelltypevisible).copy destination:=sheets("Search Results").Range("A1")

End with

or simialr....untested....

Rgds, Geoff

We could learn a lot from crayons. Some are sharp, some are pretty and some are dull. Some have weird names and all are different colours but they all live in the same box.

Please read FAQ222-2244 before you ask a question

 

[SkipVought]

Geoff,

Your method, Filter > Copy visible cells > Paste, much more efficient.

I just stuck to the OP's method.

STAR [purple]==> *[/purple] from me!

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}