Date Search Macro

Lisa1989

New Member
Joined
Sep 8, 2014
Messages
3
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
 

Some videos you may like

Excel Facts

How to create a cell-sized chart?
Tiny charts, called Sparklines, were added to Excel 2010. Look for Sparklines on the Insert tab.

pbornemeier

Well-known Member
Joined
May 24, 2005
Messages
3,848
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

New Member
Joined
Sep 8, 2014
Messages
3
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

Well-known Member
Joined
May 24, 2005
Messages
3,848
This code assumes that you have headers on Sheet2 and that Sheet2!A:K contain data (no empty columns).
Code:
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
 

Watch MrExcel Video

Forum statistics

Threads
1,109,518
Messages
5,529,314
Members
409,862
Latest member
lbisacca
Top