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

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

1 个答案: