用于将找到的行粘贴到新行的输入框 sheet

Question

我有可用的代码，但我希望能够运行它 2,3, 4 次并让它继续向下移动到目的地 sheet。相反，它会覆盖上次粘贴的内容。

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 列 sheet，将列字母更改为适合您的内容。

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

用于将找到的行粘贴到新行的输入框 sheet

Input box to paste found rows to new sheet

excel

search

vba

inputbox