Forum Discussion
Solved
Find all specific text and copy into another sheet using a do until loop
How can amend the code below to copy text at specific cells if there are more than one find.
For example, if there are 3 Finds of "OWNER" and therefore i would want all the data pertaining to "OWNER" to be copied and paste into another worksheet.
Currently the code is working fine but it is just picking up one entry of "OWNER" when there are more than 1 entries of "OWNER".
Sub findcopyandpaste()
Dim ws As Worksheet
Dim ws_N As Worksheet
Dim rng As Range
Dim adr As String
Dim lastRow As Long
Set ws = Sheet5
Set ws_N = ThisWorkbook.Sheets(Sheets.Count)
lastRow = ws_N.Cells(ws.Rows.Count, "A").End(xlUp).Row
Set rng = ws.UsedRange.find(What:="OWNER", LookAt:=xlPart)
If Not rng Is Nothing Then
adr = rng.Address
Do
rng.Offset(0, -1).Copy
ws_N.Range("B" & lastRow).Offset(1).PasteSpecial xlValues
rng.Offset(0, -2).Copy
ws_N.Range("A" & lastRow).Offset(1).PasteSpecial xlValues
Set rng = ws.UsedRange.FindNext(rng)
If rng Is Nothing Then Exit Sub
Loop Until rng.Address = adr
End If
End Sub
Thanks for the help in advance!
By the way, I'd do the loop like this, it's slightly more efficient.
Do lastRow = lastRow + 1 ws_N.Range("B" & lastRow).Value = rng.Offset(0, -1).Value ws_N.Range("A" & lastRow).Value = rng.Offset(0, -2).Value Set rng = ws.UsedRange.FindNext(rng) If rng Is Nothing Then Exit Sub Loop Until rng.Address = adr
3 Replies
By the way, I'd do the loop like this, it's slightly more efficient.
Do lastRow = lastRow + 1 ws_N.Range("B" & lastRow).Value = rng.Offset(0, -1).Value ws_N.Range("A" & lastRow).Value = rng.Offset(0, -2).Value Set rng = ws.UsedRange.FindNext(rng) If rng Is Nothing Then Exit Sub Loop Until rng.Address = adr- , thanks for the help!
You forgot to increment lastRow in the loop.
Just above Loop Until ...:
lastRow = lastRow + 1
