Date range look up and copy/paste coding

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