Need a slight modification to code

[Dean]

I am having an issue with the code below (bit beyond my skills, sorry)

While the code below is doing what it was designed to do (copy findings
to another sheet) the problem I am having is when I do a second search
of the "database" sheet the original search findings are removed or
overwritten on the "Found" sheet.

I would appreciate any ideas on how to stop further searches from
overwriting the original findings and simply add them on to the end of
the first search results. (hope this makes sense)

Thanks,

Dean


Public Sub vbaCopyToAnotherSheetRealQuickLike()
Dim rCell As Excel.Range
Dim rRow As Excel.Range
Dim wksFound As Excel.Worksheet
Dim wksData As Excel.Worksheet

Dim szLookupVal As String
Dim szRowAddy As String

Dim lRow As Long


Set wksFound = Sheets("Found") 'Sheet that gets the copied data
Set wksData = Sheets("Database") 'Sheet that contains the data to
search


lRow = wksFound.Cells(Rows.Count, 1).End(xlUp).Row

szLookupVal = InputBox("What are you searching for", "Search-Box",
"")
If Len(szLookupVal) = 0 Then Exit Sub

With wksData.Cells

Set rCell = .Find(szLookupVal, , , , , , False)
If Not rCell Is Nothing Then

szRowAddy = rCell.Address

Set rRow = rCell

Do

Set rCell = .FindNext(rCell)

Set rRow = Application.Union(rRow, rCell)

rRow.EntireRow.Copy wksFound.Cells(lRow, 1)

Loop While Not rCell Is Nothing And rCell.Address <> szRowAddy

End If
End With

Set rCell = Nothing
Set rRow = Nothing
Set wksFound = Nothing
Set wksData = Nothing
End Sub

 

[Bob Phillips]

Try changing this line

lRow = wksFound.Cells(Rows.Count, 1).End(xlUp).Row

to

lRow = wksFound.Cells(Rows.Count, 1).End(xlUp).Row + 1


--
HTH

Bob Phillips

(remove nothere from email address if mailing direct)

 

[Dean]

Thanks Bob, worked a treat.

Dean

 

[Bob Phillips]

Just noticed something else

Public Sub vbaCopyToAnotherSheetRealQuickLike()
Dim rCell As Excel.Range
Dim rRow As Excel.Range
Dim wksFound As Excel.Worksheet
Dim wksData As Excel.Worksheet

Dim szLookupVal As String
Dim szRowAddy As String

Dim lRow As Long

Set wksFound = Sheets("Found") 'Sheet that gets the copied data
Set wksData = Sheets("Database") 'Sheet that contains the data to search

lRow = wksFound.Cells(Rows.Count, 1).End(xlUp).Row
szLookupVal = InputBox("What are you searching for", "Search-Box",
"")
If Len(szLookupVal) = 0 Then Exit Sub

With wksData.Cells

Set rCell = .Find(szLookupVal, , , , , , False)
If Not rCell Is Nothing Then

szRowAddy = rCell.Address

Set rRow = rCell

Do

Set rCell = .FindNext(rCell)

Set rRow = Application.Union(rRow, rCell)

lRow = lRow + 1

rRow.EntireRow.Copy wksFound.Cells(lRow, 1)

Loop While Not rCell Is Nothing And rCell.Address <> szRowAddy

End If
End With

Set rCell = Nothing
Set rRow = Nothing
Set wksFound = Nothing
Set wksData = Nothing
End Sub

--
HTH

Bob Phillips

(remove nothere from email address if mailing direct)