Looping VBA within selected range - vba

Question

I am unable to stop my VBA from looping within the range that I have specified, could someone please check my code and tell me where I am going wrong with it.
Option Explicit
Sub Macro()
Dim oWs As Worksheet
Dim rSearchRng As Range
Dim lEndNum As Long
Dim vFindVar As Variant
Dim loc As Range
Dim LastRow As Long
Dim LRow As Long
Dim Copy As Range
Set oWs = ActiveWorkbook.Worksheets("Sheet1")
LastRow = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Offset(1).Row
lEndNum = oWs.Range("A2").End(xlDown).Row
Set Copy = oWs.Range("A2" & LRow)
Set rSearchRng = oWs.Range("A2:A" & CStr(lEndNum))
Set loc = rSearchRng.Cells.Find(Range("O2").Value)
If Not loc Is Nothing Then
Do Until loc Is Nothing
loc.Select
Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(0, 12)).Select
Selection.Copy
Sheets("Sheet2").Select
LastRow = Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Offset(1).Row
Range("A" & LastRow).Select
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
ActiveSheet.Paste
Sheets("Sheet1").Select
Application.CutCopyMode = False
Set loc = rSearchRng.FindNext(loc)
Loop
End If
Set loc = Nothing
MsgBox "Complete"
End Sub
Thanks in advance
Aydos

Answer 1

Here is a quote from the help text on FindNext
When the search reaches the end of the specified search range, it wraps around to the beginning of the range. To stop a search when this wraparound occurs, save the address of the first found cell, and then test each successive found-cell address against this saved address.
I think that applies to your situation

Answer 2

it's because Find() method keeps on going inside the range
so you have to stop it when it wraps back to the first found cell by monitoring its address, as follows (along with some other refactoring):
Sub Macro()
Dim oWs As Worksheet
Dim rSearchRng As Range
Dim lEndNum As Long
Dim vFindVar As Variant
Dim loc As Range
Dim LastRow As Long
Dim LRow As Long
Dim Copy As Range
Set oWs = ActiveWorkbook.Worksheets("Sheet1")
LastRow = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Offset(1).Row
lEndNum = oWs.Range("A2").End(xlDown).Row
Set Copy = oWs.Range("A2" & LRow)
Set rSearchRng = oWs.Range("A2:A" & CStr(lEndNum))
Dim locFirstAddress As String
Set loc = rSearchRng.Cells.Find(Range("O2").value)
If Not loc Is Nothing Then
locFirstAddress = loc.Address
Do
Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(0, 12)).Copy
With Sheets("Sheet2")
.Range("A" & .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Row).PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
.Paste
End With
Application.CutCopyMode = False
Set loc = rSearchRng.FindNext(loc)
Loop While loc.Address <> locFirstAddress
End If
Set loc = Nothing
MsgBox "Complete"
End Sub