Date range look up and copy/paste coding

Hi,

I have a little problem with some coding that I am working on.
I need some code I can assign to a button that, once clicked will prompt the user for a date range (dd/mm/yyyy to dd/mm/yyyy).
The code will then use this date range to search through upwards of 200 worksheets for any matches.
If found, it will copy certain data from those sheets, to a weekly summary sheet.

I have the code that gets the date range in the form of variables, but I don't know enough to write the code that will search the sheets and copy the required data.

Here is an example spreadsheet.

Any help on this would be greatly appreciated.

Ed

date range look up and copy.xlsx

mungel,

Attached is a modified version of the example workbook you posted. The button has been assigned to the following macro:

Sub tgr()
    
    Dim iCalc As Integer
    Dim strTemp As String
    Dim StartDate As Date
    Dim EndDate As Date
    Dim ws As Worksheet
    Dim rngName As Range
    Dim rngID As Range
    Dim rngDate As Range
    Dim rngVis As Range
    Dim VisCell As Range
    Dim arrIndex As Long
    Dim arrData() As Variant
    ReDim arrData(1 To 4, 1 To Rows.Count)
    
    With Application
        iCalc = .Calculation
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
    On Error Resume Next
    
    strTemp = InputBox("Enter the Start Date", "Start Date")
    If Trim(strTemp) = vbNullString Then GoTo ExitMacro
    StartDate = CDate(strTemp)
    If StartDate = 0 Then
        MsgBox """" & strTemp & """ is an invalid date." & Chr(10) & "Exiting Macro"
        GoTo ExitMacro
    End If
    
    strTemp = InputBox("Enter the End Date. Must be on after " & StartDate, "End Date")
    If Trim(strTemp) = vbNullString Then GoTo ExitMacro
    EndDate = CDate(strTemp)
    If EndDate = 0 Then
        MsgBox """" & strTemp & """ is an invalid date." & Chr(10) & "Exiting Macro"
        GoTo ExitMacro
    End If
    
    If EndDate < StartDate Then
        MsgBox EndDate & " is prior to " & StartDate & "." & Chr(10) & "Exiting Macro"
        GoTo ExitMacro
    End If
    
    For Each ws In ActiveWorkbook.Sheets
        If ws.Name <> ActiveSheet.Name Then
            Set rngDate = ws.Columns("A").Find("Date")
            If Not rngDate Is Nothing Then
                With Range(rngDate, ws.Cells(Rows.Count, "A").End(xlUp))
                    .AutoFilter 1, ">=" & StartDate, xlAnd, "<=" & EndDate
                    Set rngVis = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
                    If Not rngVis Is Nothing Then
                        Set rngName = ws.Columns("A").Find("Name")
                        Set rngID = ws.Columns("A").Find("ID")
                        For Each VisCell In rngVis
                            arrIndex = arrIndex + 1
                            arrData(1, arrIndex) = VisCell.Value
                            arrData(2, arrIndex) = rngName.Offset(, 1).Value
                            arrData(3, arrIndex) = rngID.Offset(, 1).Value
                            arrData(4, arrIndex) = VisCell.Offset(, 1).Value
                        Next VisCell
                        Set rngVis = Nothing
                    End If
                    .AutoFilter
                End With
            End If
        End If
    Next ws
    
    If arrIndex = 0 Then
        MsgBox "No matches found."
        GoTo ExitMacro
    Else
        ReDim Preserve arrData(1 To 4, 1 To arrIndex)
        Range("B8", Cells(Rows.Count, "E")).ClearContents
        Range("B8:E8").Resize(arrIndex).Value = Application.Transpose(arrData)
    End If

ExitMacro:
    With Application
        .Calculation = iCalc
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    
End Sub

You can save the file as a .xls and it will be a 2003 version, no adjustments needed. As a test (not in this uploaded file because it exceeded 9 MB in size), I also created 200 worksheets with each having between 20 and 1100 rows and then ran the macro on it and it ran quickly (less than 3 seconds) and properly. If you can upload a workbook that is having issues, I'll take a look at it to try to find where the problem is.

mungel,

I think I found the problem. For some reason, it wasn't calculating rngVis properly if there was only a single result. I have made a slight modification to the code which appears to have corrected that issue:

Changed this line:

If Not rngVis Is Nothing  Then

To this:

If Not rngVis Is Nothing And InStr(rngVis.Address, "$1") = 0 Then

Full code with change:

Sub tgr()
    
    Dim iCalc As Integer
    Dim strTemp As String
    Dim StartDate As Date
    Dim EndDate As Date
    Dim ws As Worksheet
    Dim rngName As Range
    Dim rngID As Range
    Dim rngDate As Range
    Dim rngVis As Range
    Dim VisCell As Range
    Dim arrIndex As Long
    Dim arrData() As Variant
    ReDim arrData(1 To 4, 1 To Rows.Count)
    
    With Application
        iCalc = .Calculation
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
    On Error Resume Next
    
    strTemp = InputBox("Enter the Start Date", "Start Date")
    If Trim(strTemp) = vbNullString Then GoTo ExitMacro
    StartDate = CDate(strTemp)
    If StartDate = 0 Then
        MsgBox """" & strTemp & """ is an invalid date." & Chr(10) & "Exiting Macro", , "Invalid Date"
        GoTo ExitMacro
    End If
    
    strTemp = InputBox("Enter the End Date. Must be on or after " & StartDate, "End Date")
    If Trim(strTemp) = vbNullString Then GoTo ExitMacro
    EndDate = CDate(strTemp)
    If EndDate = 0 Then
        MsgBox """" & strTemp & """ is an invalid date." & Chr(10) & "Exiting Macro", , "Invalid Date"
        GoTo ExitMacro
    End If
    
    If EndDate < StartDate Then
        MsgBox EndDate & " is prior to " & StartDate & "." & Chr(10) & "Exiting Macro", , "Invalid Dates"
        GoTo ExitMacro
    End If
    
    For Each ws In ActiveWorkbook.Sheets
        If ws.Name <> ActiveSheet.Name Then
            Set rngDate = ws.Columns("A").Find("Date")
            If Not rngDate Is Nothing Then
                With Range(rngDate, ws.Cells(Rows.Count, "A").End(xlUp))
                    .AutoFilter 1, ">=" & StartDate, xlAnd, "<=" & EndDate
                    Set rngVis = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
                    If Not rngVis Is Nothing And InStr(rngVis.Address, "$1") = 0 Then
                        Set rngName = ws.Columns("A").Find("Name")
                        Set rngID = ws.Columns("A").Find("ID")
                        For Each VisCell In rngVis
                            arrIndex = arrIndex + 1
                            arrData(1, arrIndex) = VisCell.Value
                            arrData(2, arrIndex) = rngName.Offset(, 1).Value
                            arrData(3, arrIndex) = rngID.Offset(, 1).Value
                            arrData(4, arrIndex) = VisCell.Offset(, 1).Value
                        Next VisCell
                        Set rngVis = Nothing
                    End If
                    .AutoFilter
                End With
            End If
        End If
    Next ws
    
    If arrIndex = 0 Then
        MsgBox "No matches found.", , "No Matches"
        GoTo ExitMacro
    Else
        ReDim Preserve arrData(1 To 4, 1 To arrIndex)
        Range("B8", Cells(Rows.Count, "E")).ClearContents
        Range("B8:E8").Resize(arrIndex).Value = Application.Transpose(arrData)
    End If

ExitMacro:
    With Application
        .Calculation = iCalc
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    
End Sub

mungel,

I found the issue that was causing the second the problem and have corrected it. I was unable to duplicate the first issue you mentioned.

Hi again,

I think I have figured out the problem, but I have no clue how to remedy it.
It has to do with the date format.
Here in the UK the standard date format is dd/mm/yyyy and all the worksheets will have the date formatted that way.
The macro you wrote is reading the date range entered by the user as mm/dd/yyyy and thus producing incorrect results.
To test this, I changed the dates in the worksheets back to between 01 January 2012 and 10 January 2012 and did a search range of 01/01/2012 and 03/01/2012.
This search range displayed every result, as it was searching from 01 January 2012 to 01 March 2012 and not 01 January to 03 January as I thought it was.
A search range of 01/01/2012 and 01/03/2012 worked correctly, only producing a few results.

So is there a way to force the macro to accept a dd/mm/yyyy format?
This is the format here in the UK and everyone entering dates or running searches will be entering dates in this format.

As a side issue, and out of curiosity, I changed the format of the date cells to dd/mmm/yyyy so that all the dates were shown in full (01 January 2012 to 10 January 2012)
I also changed the format of the destination cells on the weekly worksheet to match this.
When I did a search for 01/01/2012 to 03/01/2012 (January to March in US format) it produced all the results (as expected) but changed the dates in the destination cells.
So even though the date was displayed as 06 January 2012 on the worksheet, when copied into the weekly worksheet, it became 01 June 2012.
This change happened to every result, making them all incorrect, even though they were displayed correctly before being copied.

Attached is the very workbook I was just using. You should be able to replicate the results above and see the issues I am highlighting.

Once again, and probably not for the last time, I am expressing my eternal gratitude for your assistance on this matter.
I may end up buying you a crate of beer or something..

Thanks,

Ed

mungel,

Excel should use whatever your computer's Regional and Date settings are set to. I changed mine to English (United Kingdom) and it worked as expected with d/m/y date format entries.

THere are two things I would change:
1. Use CLng to convert the date criteria when autofiltering.
2. Use:

arrData(1, arrIndex) = VisCell.Value2
                            arrData(2, arrIndex) = rngName.Offset(, 1).Value2
                            arrData(3, arrIndex) = rngID.Offset(, 1).Value2
                            arrData(4, arrIndex) = VisCell.Offset(, 1).Value2

to avoid date issues when populating the array.

Cdate should always apply your regional settings so if you enter a UK date string, that is what should be output. Can you post the exact code, preferably in a sample workbook so we can verify data too, and a specific example failing for you?