将找到的行粘贴到新工作表的输入框

Question

我有什么是工作代码，但我希望能够运行它2,3,4次，并让它只是沿着目标工作表向下移动。相反，它会覆盖最后一次粘贴的内容。

Sub Comparison_Entry() 

Dim myWord$ 

myWord = InputBox("Enter UID, If no more UIDs, enter nothing and click OK", "Enter User") 
    If myWord = "" Then Exit Sub 

Application.ScreenUpdating = False 
Dim xRow&, NextRow&, LastRow& 
NextRow = 1 
LastRow = Cells.Find(What:="*", After:=Range("A1"), SearchOrder:=xlByRows,  SearchDirection:=xlPrevious).Row 
For xRow = 1 To LastRow 
If WorksheetFunction.CountIf(Rows(xRow), "*" & myWord & "*") > 0 Then 
Rows(xRow).Copy Sheets("Sheet1").Rows(NextRow) 
NextRow = NextRow + 1 
End If 
Next xRow 
Application.ScreenUpdating = True 

MsgBox "Copyng complete, " & NextRow - 2 & " rows containing" & vbCrLf & _ 
"''" & myWord & "''" & " were copied to Sheet1.", 64, "Done" 

End Sub`` 

我试着给这个添加一个循环，但是每次通过它都会从Sheet1的顶部开始。同样，如果我再次调用Sub，我会得到相同的结果。

Answer 1

通常你会知道通过搜索什么样的列，比如什么列UID。在这个示例代码中，我将假设它是活动工作表的A列，将列字母更改为您的套件。

Sub Comparison_EntryB() 

    Dim Rws As Long, rng As Range, c As Range 
    Dim ws As Worksheet, sh As Worksheet, s As String 

    Set ws = ActiveSheet 
    Set sh = Sheets("Sheet1") 

    With ws 
     Rws = .Cells(.Rows.Count, "A").End(xlUp).Row 'change to column you need you search through 
     Set rng = .Range(.Cells(1, "A"), .Cells(Rws, "A")) 'change to column you need to search through 
    End With 

    s = InputBox("enter Something") 

    For Each c In rng.Cells 
     If UCase(c) Like "*" & UCase(s) & "*" Then 
      c.EntireRow.Copy sh.Cells(sh.Rows.Count, "A").End(xlUp).Offset(1) 
     End If 
    Next c 

End Sub