'============================================
'- 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