循环浏览筛选的单元格列表，检查值是否出现在另一列中，然后复制/粘贴

Question

我的宏需要一些帮助。我需要的是循环浏览Sheet2中的可过滤的ID列表，并将它们与Sheet1第16列中包含ID的位置匹配。然后将Sheet1中匹配的整行复制到Sheet3中。

以下是Sheet2的一般情况(通过状态等进行过滤(：

创建日期状态日期日期

ID	摘要
123467	文本	完成
2345678	文本	进行中

我可能会尝试这样的方法：

Public Sub PairingBackTEST()

Dim wb As Workbook
Dim wsList As Worksheet, wsCheck As Worksheet, wsResults As Worksheet
Dim lrList As Long, lrCheck As Long, c As Range, cDest As Range, id, m

'use workbook/worksheet variables for clarity, and to avoid repetition...
Set wb = ThisWorkbook
Set wsList = wb.Worksheets("Sheet2")
Set wsCheck = wb.Worksheets("Sheet1")
Set wsResults = wb.Worksheets("Sheet3")
'no need for activate/select here
With wsResults
.Cells.Clear
.Columns("H:H").NumberFormat = "[$-en-US]m/d/yy h:mm AM/PM;@"
'.Columns("I:I").NumberFormat = ??? this is missing in your posted code
wsCheck.Rows(1).Copy .Range("A1") 'copy headers
End With
Set cDest = wsResults.Range("A2") 'first destination row on result sheet
For Each c In wsList.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells
id = c.Value
'you can use match in place of looping as long as there's only one row to find
m = Application.Match("*" & id & "*", wsCheck.Columns(16), 0)
If Not IsError(m) Then
If m > 1 Then 'avoid matching on header...
cDest.Resize(1, 17).Value = wsCheck.Cells(m, 1).Resize(1, 17).Value
Set cDest = cDest.Offset(1, 0) 'next row on results sheet
End If
End If
Next c
End Sub