FIND RECORDS AND PUT INTO A SUMMARY SHEET (SOLVED)

Brian

Have just tred out this macro which is exactly what I need for my workbook

If I seach say 'ADSA' in my data it finds/copies the correct number of entries BUT they are all same as first entry found.

I have changed macro to copy all the row to target sheetwith no problem

Thanks

Steve

If you have changed the macro there is no point in replying to the original version - which is tried and tested. You should post your code into a new message for correction.

Need some adjusting done to this macro

After looking around the board I finally found a macro that kind of does what I want it to do. When I execute this macro it returns the same data on down the form called summary. I need it to copy the rows down exactly as my Data base is listed when it found the result that I have inputted.

Please Help.


'============================================
'- 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
Set FromSheet = ThisWorkbook.Worksheets("sheet1")
Set ToSheet = ThisWorkbook.Worksheets("Summary")
ToRow = 8
'---------------------------------------------------
'- get user input
FindThis = InputBox("Please enter data to find : ")
If FindThis = "" Then End ' trap Cancel
'---------------------------------------------------
'- clear summary for new data
ToSheet.Cells.ClearContents
'---------------------------------------------------
' FIND DATA
'-




With FromSheet.Cells
Set FoundCell = .Find(FindThis, LookIn:=xlValues)
If Not FoundCell Is Nothing Then
FirstAddress = FoundCell.Address
FromRow = FoundCell.Row
'------------------------------------------
'- copy data to summary
Do
ToSheet.Cells(ToRow, 1).Value = _
FromSheet.Cells(FromRow, 1).Value
ToSheet.Cells(ToRow, 2).Value = _
FromSheet.Cells(FromRow, 2).Value
ToSheet.Cells(ToRow, 3).Value = _
FromSheet.Cells(FromRow, 3).Value
ToRow = ToRow + 1
Set FoundCell = .FindNext(FoundCell)
Loop While Not FoundCell Is Nothing And _
FoundCell.Address <> FirstAddress
'------------------------------------------
End If
End With
MsgBox ("Done.")
Application.Calculation = xlCalculationAutomatic
End Sub