Use Find to search and return Multiple Dates

thomachr

Board Regular
Joined
Mar 13, 2007
Messages
53
I am working with a macro into which you input a date, the macro searches for that date (in column D of the data sheet), then copies any row with that date onto a new sheet.

This works great, but now I need to be able to search for more than one date at a time and return any rows that cantain ANY of those dates. For example, I would want to search for any row containing 01/01/07 - 01/07/07 or any row containing 01/01/07, 01/02/07, 01/03/07...01/07/07.

Does anyone know of a way I could edit the macro to search for more than one date at a time?
 

Excel Facts

Square and cube roots
The =SQRT(25) is a square root. For a cube root, use =125^(1/3). For a fourth root, use =625^(1/4).

thomachr

Board Regular
Joined
Mar 13, 2007
Messages
53
Could you post your code?

This is not originally my code. It has been adapted from code I found on this board, with credit given:

Code:
'============================================
'- FIND RECORDS IN A DATA TABLE
'- AND PUT INTO A SUMMARY SHEET
'- needs a sheet called "Summary"
'- change "DataSheet" to lookup sheet name
'- Brian Baulsom February 2005
'=============================================
'-
Sub FindRecords()
    Dim FromSheet As Worksheet
    Dim FromRow As Long
    Dim ToSheet As Worksheet
    Dim ToRow As Long
    Dim FindThis As Variant
    Dim FoundCell As Object
    '---------------------------------------------------
    Application.Calculation = xlCalculationManual
   
    '---------------------------------------------------
    '- get user input
    FindThis = InputBox("Please enter first date to search : ")
    If FindThis = "" Then End ' trap Cancel
    
    '---------------------------------------------------
    Set WBfrom = Workbooks.Open(Filename:="N:\pub\Supply Chain Quality\IQA\IQA Log's\2007 logs\NCR Log 2007 (On NCR Only)")
    Set FromSheet = WBfrom.Worksheets("Sheet1")
    Set ToSheet = ThisWorkbook.Worksheets("Search NCR Log by Date")
    ToRow = 2
    '---------------------------------------------------
    '- clear summary for new data
    ToSheet.Cells.Range("A2:BC57").Clear
    '---------------------------------------------------
    ' FIND DATA
    '-
    With FromSheet.Range("D1:D5000")
        Set FoundCell = .Find(FindThis, LookIn:=xlValues)
        If Not FoundCell Is Nothing Then
            FirstAddress = FoundCell.Address
            '------------------------------------------
            '- copy data to summary
            Do
                FromRow = FoundCell.Row
                FromSheet.Cells(FromRow, 1).Copy
                    ToSheet.Cells(ToRow, 1).PasteSpecial xlAll
                FromSheet.Cells(FromRow, 2).Copy
                    ToSheet.Cells(ToRow, 2).PasteSpecial xlAll
                FromSheet.Cells(FromRow, 4).Copy
                    ToSheet.Cells(ToRow, 3).PasteSpecial xlAll
                FromSheet.Cells(FromRow, 6).Copy
                    ToSheet.Cells(ToRow, 4).PasteSpecial xlAll
                FromSheet.Cells(FromRow, 7).Copy
                    ToSheet.Cells(ToRow, 5).PasteSpecial xlAll
                FromSheet.Cells(FromRow, 8).Copy
                    ToSheet.Cells(ToRow, 6).PasteSpecial xlAll
                FromSheet.Cells(FromRow, 10).Copy
                    ToSheet.Cells(ToRow, 7).PasteSpecial xlAll
                FromSheet.Cells(FromRow, 11).Copy
                    ToSheet.Cells(ToRow, 8).PasteSpecial xlAll
                FromSheet.Cells(FromRow, 13).Copy
                    ToSheet.Cells(ToRow, 9).PasteSpecial xlAll
                FromSheet.Cells(FromRow, 19).Copy
                    ToSheet.Cells(ToRow, 10).PasteSpecial xlAll
                FromSheet.Cells(FromRow, 28).Copy
                    ToSheet.Cells(ToRow, 11).PasteSpecial xlAll
                    
                
                ToRow = ToRow + 1
                Set FoundCell = .FindNext(FoundCell)
            Loop While Not FoundCell Is Nothing And _
                FoundCell.Address <> FirstAddress
        
      
            '------------------------------------------
        End If
    End With
    Application.Workbooks("NCR Log 2007 (On NCR Only)").Close SaveChanges:=False
    MsgBox ("Done.")
    Application.Calculation = xlCalculationAutomatic
End Sub
 

brian.wethington

Well-known Member
Joined
Jul 20, 2006
Messages
1,739
How large of a range is this being performed on? there could be some other ways to perform this task.
 

thomachr

Board Regular
Joined
Mar 13, 2007
Messages
53

ADVERTISEMENT

How large of a range is this being performed on? there could be some other ways to perform this task.

I have data from from column A to BE. This being said, the last column I need reported is AB. At the begining of the year it was formatted for 5000 rows, but I currently only have data up to ~400. The solution would need to accomodate the possibility of at least 1000 rows.
 

brian.wethington

Well-known Member
Joined
Jul 20, 2006
Messages
1,739
This is mostly a guess, give it a try and see if it might work in your situation (I have not been able to test it for your specific situation):
Code:
'============================================
'- Update July 2007
'- FIND RECORDS IN A DATA TABLE
'- AND PUT INTO A SUMMARY SHEET
'- needs a sheet called "Summary"
'- change "DataSheet" to lookup sheet name
'- Brian Baulsom February 2005
'=============================================
'-
Sub FindRecords()
    Dim FromSheet As Worksheet, FromRow As Long, ToSheet As Worksheet, ToRow As Long, FindThis As Date, FoundCell As Object
    Dim Wbfrom As Workbook, FirstAddress As String
    'New dim section
    Dim FindThis2 As Date, RngLen As Long, x As Long
    '---------------------------------------------------
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    
    '---------------------------------------------------
    '- get user inputs
    FindThis = InputBox("Please enter start date (Enter in Format MM/DD/YYYY): ")
    FindThis2 = InputBox("Please enter end date (Enter in Format MM/DD/YYYY): ")
    If FindThis2 > FindThis Then
        RngLen = FindThis2 - FindThis
    Else
        RngLen = FindThis - FindThis2
    End If
    
    '---------------------------------------------------
    Set Wbfrom = Workbooks.Open(Filename:="N:\pub\Supply Chain Quality\IQA\IQA Log's\2007 logs\NCR Log 2007 (On NCR Only)")
    Set FromSheet = Wbfrom.Worksheets("Sheet1")
    Set ToSheet = ThisWorkbook.Worksheets("Search NCR Log by Date")
    ToRow = 2
    '---------------------------------------------------
    '- clear summary for new data
    ToSheet.Cells.Range("A2:BC57").Clear
    '---------------------------------------------------
    ' FIND DATA
    '-
    For x = 0 To RngLen
        With FromSheet.Range("D1:D5000")
            Set FoundCell = .Find(FindThis + x, LookIn:=xlValues)
            If Not FoundCell Is Nothing Then
                FirstAddress = FoundCell.Address
                '------------------------------------------
                '- copy data to summary
                Do
                    FromRow = FoundCell.Row
                    FromSheet.Cells(FromRow, 1).Copy ToSheet.Cells(ToRow, 1)
                    FromSheet.Cells(FromRow, 2).Copy ToSheet.Cells(ToRow, 2)
                    FromSheet.Cells(FromRow, 4).Copy ToSheet.Cells(ToRow, 3)
                    FromSheet.Cells(FromRow, 6).Copy ToSheet.Cells(ToRow, 4)
                    FromSheet.Cells(FromRow, 7).Copy ToSheet.Cells(ToRow, 5)
                    FromSheet.Cells(FromRow, 8).Copy ToSheet.Cells(ToRow, 6)
                    FromSheet.Cells(FromRow, 10).Copy ToSheet.Cells(ToRow, 7)
                    FromSheet.Cells(FromRow, 11).Copy ToSheet.Cells(ToRow, 8)
                    FromSheet.Cells(FromRow, 13).Copy ToSheet.Cells(ToRow, 9)
                    FromSheet.Cells(FromRow, 19).Copy ToSheet.Cells(ToRow, 10)
                    FromSheet.Cells(FromRow, 28).Copy ToSheet.Cells(ToRow, 11)
                        
                    
                    ToRow = ToRow + 1
                    Set FoundCell = .FindNext(FoundCell)
                Loop While Not FoundCell Is Nothing And _
                    FoundCell.Address <> FirstAddress
            
          
                '------------------------------------------
            End If
        End With
    Next x
    Application.Workbooks("NCR Log 2007 (On NCR Only)").Close SaveChanges:=False
    MsgBox ("Done.")
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub
Hope this is helpful!
 

thomachr

Board Regular
Joined
Mar 13, 2007
Messages
53

ADVERTISEMENT

Brian - I reall apreaciate you taking a crack at this and trying to help me out!

I think you have the right idea, but something is not quite right in the execution. The code runs without any erros, but returns a blank sheet instead of the data I am looking for.

It seems to be acting like it is searching but not finding any of the corresponding dates, which is not the case. I am wondering if there is a problem because the dates are formatted as dates in the original data. I did a test using the manual find command for a date (MM/DD/YYYY) and found the cell, but when I searched for the number equivilant excel found nothing. Is this where the problem lies, and if so, is there any way to fix it without having to change or reformat the original data?

Any other thoughts? Thanks!
 

brian.wethington

Well-known Member
Joined
Jul 20, 2006
Messages
1,739
How is your data formatted in your sheet?

If you go into the formatting of a cell that contains a date what is the formatting? Is it a date or not?
 

thomachr

Board Regular
Joined
Mar 13, 2007
Messages
53
How is your data formatted in your sheet?

If you go into the formatting of a cell that contains a date what is the formatting? Is it a date or not?

The cells are formatted in the date format of MM/DD/YY.

The cells are also protected, would that make a difference?
 

brian.wethington

Well-known Member
Joined
Jul 20, 2006
Messages
1,739
I have been testing using this (much smaller scale) and it is working for me with or without protection.

Code:
Option Explicit
'============================================
'- Update July 2007
'- FIND RECORDS IN A DATA TABLE
'- AND PUT INTO A SUMMARY SHEET
'- needs a sheet called "Summary"
'- change "DataSheet" to lookup sheet name
'- Brian Baulsom February 2005
'=============================================
Sub FindRecords()
    Dim FromSheet As Worksheet, FromRow As Long, ToSheet As Worksheet, ToRow As Long, FindThis As Date, FoundCell As Object
    Dim Wbfrom As Workbook, FirstAddress As String
    'New dim section
    Dim FindThis2 As Date, RngLen As Long, x As Long
    '---------------------------------------------------
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    
    '---------------------------------------------------
    '- get user inputs
    FindThis = InputBox("Please enter start date (Enter in Format MM/DD/YYYY): ")
    FindThis2 = InputBox("Please enter end date (Enter in Format MM/DD/YYYY): ")
    If FindThis2 > FindThis Then
        RngLen = FindThis2 - FindThis
    Else
        RngLen = FindThis - FindThis2
    End If
    
    '---------------------------------------------------
    Set FromSheet = Worksheets("Sheet1")
    Set ToSheet = Worksheets("Search NCR Log by Date")
    ToRow = 2
    '---------------------------------------------------
    '- clear summary for new data
    ToSheet.Cells.Clear
    '---------------------------------------------------
    ' FIND DATA
    For x = 0 To RngLen
        With FromSheet.Range("D1:D5000")
            Set FoundCell = .Find(FindThis + x, LookIn:=xlValues)
            If Not FoundCell Is Nothing Then
                FirstAddress = FoundCell.Address
                '------------------------------------------
                '- copy data to summary
                Do
                    FromRow = FoundCell.Row
                    FromSheet.Range(Cells(FromRow, 1), Cells(FromRow, 2)).Copy ToSheet.Cells(ToRow, 1)
                    FromSheet.Cells(FromRow, 4).Copy ToSheet.Cells(ToRow, 3)
                    FromSheet.Range(Cells(FromRow, 6), Cells(FromRow, 8)).Copy ToSheet.Cells(ToRow, 4)
                    FromSheet.Range(Cells(FromRow, 10), Cells(FromRow, 11)).Copy ToSheet.Cells(ToRow, 7)
                    FromSheet.Cells(FromRow, 13).Copy ToSheet.Cells(ToRow, 9)
                    FromSheet.Cells(FromRow, 19).Copy ToSheet.Cells(ToRow, 10)
                    FromSheet.Cells(FromRow, 28).Copy ToSheet.Cells(ToRow, 11)
                        
                    
                    ToRow = ToRow + 1
                    Set FoundCell = .FindNext(FoundCell)
                Loop While Not FoundCell Is Nothing And _
                    FoundCell.Address <> FirstAddress
            
          
                '------------------------------------------
            End If
        End With
    Next x
    MsgBox "Done."
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub
I am not sure what I am missing with your specific situation.

I am supposed to be looking for the dates in Column D for sure right?
 
Learn Excel from Bill Jelen

Understanding data is crucial, and the easiest place to start is with Microsoft Excel.

Forum statistics

Threads
1,151,491
Messages
5,764,681
Members
425,229
Latest member
Rashid mahmood

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top