使用输入框连续搜索字符串，复制该行中选定的单元格并将其粘贴到新工作表上

Question

我希望在一个脚本中完成以下步骤：

通过输入框进行用户输入。 在工作表（“ Sheet3”）中搜索该文本。 复制5个单元格B7，D7，F7，G7，I7 从搜索到的单元格中粘贴 然后在单元格B2，C2，D2，E2，F2上进入Worksheet（“ Sheet2”）

这是我的代码。

    Dim rId As Range, celS As Range, celT As Range
Dim wS As Worksheet, wT As Worksheet
Dim sId As String

Set wS = Worksheets("Sheet3")
Set wT = Worksheets("Sheet2")
Set celT = wT.Range("B2")

    sId = InputBox("Enter ID")
    If Len(sId) = 0 Then Exit Sub

    Set rId = wS.Range("A2:BM2210") 'start of search area
    Set rId = wS.Range(rId, wS.Cells(wS.Rows.Count, rId.Column).End(xlUp)) 'rest of data

    Set celS = rId.Find(sId, , xlValues, xlWhole, , , False)

    If Not celS Is Nothing Then
        Set celS = Intersect(wS.Columns("A:B"), celS.EntireRow) 'extract name
        If Not IsEmpty(celT) Then 'find next empty cell in target sheet
            Set celT = wT.Cells(wT.Rows.Count, celT.Column).End(xlUp).Offset(1)
        End If
        celT.Value = celS.Value
    End If