Hi All,

I am wanting to use the code shown below to retrieve data that is between the two specified dates (>=01/04/07 and <=30/04/07 for example).

When I input the above dates in to the two cells, the macro returns data from 01/04/07 through to today, rather than ending at 30/04/07.

However, if I input 01/04/07 and 30/04/07, the macro will return data for those two dates (as I would have expected). I am therefore assuming that a slight amendment is needed in the code, but I can't find it!!

Any help would be much appreciated - if any further detail is required, please let me know..

Thanks in anticipation of any help.

David

Sub Button35_Click()

Dim MaxResults As Long, MyCol As Integer, ResultsRng As String
Dim MyRow As Integer, LastDataRow As Integer, DataRng As String
Dim CritRow As Integer, CritRng As String, RightCol As Integer
Dim TopRow As Integer, BottomRow As Integer, LeftCol As Integer

Range("H17:M50000").ClearContents



DataRng = "A10:F10" ' range of column headers for Data table
CritRng = "H10:M12" ' range of cells for Criteria table
ResultsRng = "H16:M16" ' range of headers for Results table
MaxResults = 40000 ' any value higher than the number of possible results

' **************** END OF DECLARATIONS *********************

' fix the data range to incorporate the last row

TopRow = Range(DataRng).Row
LeftCol = Range(DataRng).Column
RightCol = LeftCol + Range(DataRng).Columns.Count - 1
DataRng = Range(Cells(TopRow, LeftCol), Cells(LastDataRow, RightCol)).Address

' fix the results range to incorporate the last row

TopRow = Range(ResultsRng).Row
LeftCol = Range(ResultsRng).Column
RightCol = LeftCol + Range(ResultsRng).Columns.Count - 1
ResultsRng = Range(Cells(TopRow + 1, LeftCol), Cells(MaxResults, RightCol)).Address
Range(ResultsRng).ClearContents ' clear any previous results but not headers
ResultsRng = Range(Cells(TopRow, LeftCol), Cells(MaxResults, RightCol)).Address

' fix the criteria range and identify the last row containing any items

TopRow = Range(CritRng).Row
BottomRow = TopRow + Range(CritRng).Rows.Count - 1
LeftCol = Range(CritRng).Column
RightCol = LeftCol + Range(CritRng).Columns.Count - 1
CritRow = 0

For MyRow = TopRow + 1 To BottomRow
For MyCol = LeftCol To RightCol
If Cells(MyRow, MyCol).Value <> "" Then CritRow = MyRow
Next
Next

If CritRow = 0 Then
MsgBox "No Criteria detected"
Else
CritRng = Range(Cells(TopRow, LeftCol), Cells(CritRow, RightCol)).Address
Debug.Print "DataRng, CritRng, ResultsRng: ", DataRng, CritRng, ResultsRng

Worksheets("Data").Range(DataRng).AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Range(CritRng), CopyToRange:=Range(ResultsRng), _
Unique:=False
End If
Range("A5").Select
End Sub