Use Find to search and return Multiple Dates

T

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

Is there a shortcut key for strikethrough?
Ctrl+S is used for Save. Ctrl+5 is used for Strikethrough. Why Ctrl+5? When you use hashmarks to count |||| is 4, strike through to mean 5.
Sort by date Sort by votes
Could you post your code?
Click to expand...

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
 
Upvote 0
How large of a range is this being performed on? there could be some other ways to perform this task.
Click to expand...

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.
 
Upvote 0
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!
 
Upvote 0
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!
 
Upvote 0
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?
 
Upvote 0
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?
Click to expand...

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

The cells are also protected, would that make a difference?
 
Upvote 0
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?
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Solved
Add 1 day to a date within a range as long as 2 conditions are met [without macros]
Replies
4
Views
563
juanam
J
P
  • Question
Excel pivot with milestones across the various dates to show as a months on the left and a count of that milestone on the right
Replies
1
Views
201
POLACOLOCO
P
A
  • Solved
Returning name on multiple date arrays
Replies
9
Views
379
archibell
A
A
  • Question
Insert new column(DATE) up to finish month and move to next sheet
Replies
0
Views
121
Amer Omar
A
D
  • Question
Rounding Negative time to the nearest minute in Excel
Replies
4
Views
81
Scott Huish
Scott Huish

Forum statistics

Threads
1,214,822
Messages
6,121,772
Members
449,049
Latest member
greyangel23

Share this page

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
Back
Top