Date Search Macro

[Lisa1989]

Hi Guys,

It's been a very long time since I've done anything in VBA and I'm struggling to get a Macro to do what I want.

Basically I have a customer database I've setup an entry form (sheet 1) and macro to copy the data to the database (Sheet 2) which automatically calculates a follow-up date a year from installation date.

What I need to do is create a search facility so I can put in a date range e.g. "September 2014" and the macro search the follow up dates and extract all relevant records and paste them into a new workbook so I can run a mailmerge with the follow up letter.

Dates are entered in the following format dd/mm/yyyy

Any help would be fantastic, it's been about 7 years since I've done anything like this and rusty doesn't even cover it!!!

Thanks,

Lisa

 

[pbornemeier]

Welcome to the Board!

Q1. What column/range on sheet2 holds the dates you want to search through?
Q2a. What cell on sheet 1 holds the date you want to search for?
Q2b. Or do you want to enter start date in 1 cell and end date in another?
Q3. What range before, after or around the date in Q2 range do you want? Q2 to Q2+30 days? 2 to Q2-30 days? Q2+/- 15 days? The month the Q2 is in? Pick one or make something else up.
Q4. What columns in the matching date rows on Sheet2 to you want to copy to a new workbook?
Q5. What should the name of that workbook be?

 

[Lisa1989]

Hi,

Thanks for responding, in answer to your questions:

Q1. What column/range on sheet2 holds the dates you want to search through? It's column K
Q2a. What cell on sheet 1 holds the date you want to search for?
Q2b. Or do you want to enter start date in 1 cell and end date in another? The start date would be input to sheet 1 (titled Input Screen) F17 and the end date F18
Q3. What range before, after or around the date in Q2 range do you want? Q2 to Q2+30 days? 2 to Q2-30 days? Q2+/- 15 days? The month the Q2 is in? Pick one or make something else up. I want to search for all records between the dates entered in F17 & F18
Q4. What columns in the matching date rows on Sheet2 to you want to copy to a new workbook?It needs to copy all columns from B to G
Q5. What should the name of that workbook be? MM Extraction followed by the extraction date e.g. if this was saved today it would be MM Extraction 13.09.2014

Thanks for your help with this, I've been racking my brains all week how to get around it!

Lisa

 

[pbornemeier]

This code assumes that you have headers on Sheet2 and that Sheet2!A:K contain data (no empty columns).

Option Explicit

Sub ExtractDataByDateRangeAndExport()

    Dim sWorksheet As String
    Dim dteStart As Date
    Dim dteEnd As Date
    Dim lLastSheet2DataRow As Long
    Dim lExportedRowCount As Long
    
    'Create export worksheet
    sWorksheet = "MM Extraction " & Format(Now(), "dd.mm.yyyy")
    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets(sWorksheet).Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    Worksheets.Add(After:=Sheets(Sheets.Count)).Name = sWorksheet 'After last
    
    'Get Date range.  No checks done for valid dates or End Date after Start Date
    With Worksheets("Input Screen")
        dteStart = .Range("F17")
        dteEnd = .Range("F18")
    End With
    
    'Filter and Export
    With Worksheets("Sheet2")
        .AutoFilterMode = False
        lLastSheet2DataRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        .Range("A1").CurrentRegion.AutoFilter Field:=11, _
            Criteria1:=">=" & Format(dteStart, "m/d/yyyy"), Operator:=xlAnd, _
            Criteria2:="<=" & Format(dteEnd, "m/d/yyyy")
        If Application.WorksheetFunction.Subtotal(3, .Columns("K")) > 1 Then 'Row other than header was filtered
            .Range("B1:G" & lLastSheet2DataRow).SpecialCells(xlCellTypeVisible).Copy _
                Destination:=Worksheets(sWorksheet).Range("A1")
            With Worksheets(sWorksheet)
                lExportedRowCount = .Cells(.Rows.Count, 1).End(xlUp).Row
                .Move 'moves worksheet to new workbook which becomes the activeworkbook
            End With
            With ActiveWorkbook
                .SaveAs sWorksheet & ".xlsx", FileFormat:=51 'xlsx
                .Close
            End With
            MsgBox lExportedRowCount - 1 & " rows exported to " & sWorksheet & ".xlsx", , "Data Exported"
        Else
            MsgBox "No rows fall within the date range: " & Format(dteStart, "dd.mm.yyyy") & " to " & _
                Format(dteEnd, "dd.mm.yyyy"), , "No Rows Filtered"
        End If

        .AutoFilterMode = False
    End With

End Sub

 

[Lisa1989]

Hi,

Thats for this it's fantastic, does exactly what I needed!

Lisa