在选定范围内循环VBA

我无法阻止VBA在我指定的范围内循环，请有人检查我的代码并告诉我哪里出了问题

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

提前谢谢

---

Aydos

以下是FindNext帮助文本中的一段引用

当搜索到达指定搜索范围的末尾时，它将环绕到该范围的开头。若要在发生此环绕时停止搜索，请保存第一个找到的单元格的地址，然后根据此保存的地址测试每个连续找到的单元格地址

我认为这适用于您的情况，因为Find（）方法一直在范围内运行 因此，当它返回到第一个找到的单元格时，您必须通过监视其地址来停止它，如下所示（以及一些其他重构）：

Sub宏（）
将oWs设置为工作表
调光范围
长的一样暗
Dim vFindVar作为变量
Dim loc As范围
最后一排一样长
暗淡的光线和长的一样
暗拷贝作为范围
设置oWs=ActiveWorkbook.Worksheets（“Sheet1”）
LastRow=图纸（“Sheet1”）。单元格（Rows.Count，1）。结束（xlUp）。偏移量（1）。行
lEndNum=oWs.Range（“A2”）.End（xlDown）.Row
设置副本=oWs.Range（“A2”&LRow）
设置rSearchRng=oWs.Range（“A2:A”和CStr（lEndNum））
Dim locFirstAddress作为字符串
Set loc=rSearchRng.Cells.Find（范围（“O2”）.值）
如果不是，那就什么都不是了
locFirstAddress=位置地址
做
范围（ActiveCell.Offset（0,0），ActiveCell.Offset（0,12））。复制
附页（“第2页”）
.Range（“A”和.Cells（.Rows.Count，1）.End（xlUp）.Offset（1）.Row）.Paste特殊粘贴：=xlPasteColumnWidths，操作：=xlNone，SkipBlanks:=False，转置：=False
粘贴
以
Application.CutCopyMode=False
Set loc=rSearchRng.FindNext（loc）
loc.Address locFirstAddress时循环
如果结束
设置loc=无
MsgBox“完成”
端接头

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