Option Explicit
Sub FindSample2()
Dim ws As Worksheet
Dim rgSearchIn As Range
Dim rgFound As Range
Dim sFirstFound As String
Dim bContinue As Boolean
ReSetFoundList '初始化要复制的列表区域
  Set ws = ThisWorkbook.Worksheets("sheet1")
bContinue = True
Set rgSearchIn = GetSearchRange(ws) '获取查找区域

'设置查找参数
  Set rgFound = rgSearchIn.Find(what:=ws.Range("I1").Value, _
LookIn:=xlValues, LookAt:=xlWhole)
'获取第一个满足条件的单元格地址,作为结束循环的条件
  If Not rgFound Is Nothing Then sFirstFound = rgFound.Address
Do Until rgFound Is Nothing Or Not bContinue
CopyItem rgFound
Set rgFound = rgSearchIn.FindNext(rgFound)
'判断循环是否中止
    If rgFound.Address = sFirstFound Then bContinue = False
Loop
Set rgSearchIn = Nothing
Set rgFound = Nothing
Set ws = Nothing
End Sub
'获取查找区域,即B列中的"部位"单元格区域
Private Function GetSearchRange(ws As Worksheet) As Range
Dim lLastRow As Long
lLastRow = ws.Cells(65536, 1).End(xlUp).Row
Set GetSearchRange = ws.Range(ws.Cells(1, 2), ws.Cells(lLastRow, 2))
End Function
'复制查找到的数据到found区域
Private Sub CopyItem(rgItem As Range)
Dim rgDestination As Range
Dim rgEntireItem As Range
'获取在查找区域中的整行数据
  Set rgEntireItem = rgItem.Offset(0, -1)
Set rgEntireItem = rgEntireItem.Resize(1, 4)
Set rgDestination = rgItem.Parent.Range("found")
'定位要复制到的found区域的第一行
  If IsEmpty(rgDestination.Offset(1, 0)) Then
Set rgDestination = rgDestination.Offset(1, 0)
Else
Set rgDestination = rgDestination.End(xlDown).Offset(1, 0)
End If
'复制找到的数据到found区域
  rgEntireItem.Copy rgDestination
Set rgDestination = Nothing
Set rgEntireItem = Nothing
End Sub
'初始化要复制到的区域(found区域)
Private Sub ReSetFoundList()
Dim ws As Worksheet
Dim lLastRow As Long
Dim rgTopLeft As Range
Dim rgBottomRight As Range
Set ws = ThisWorkbook.Worksheets("sheet1")
Set rgTopLeft = ws.Range("found").Offset(1, 0)
lLastRow = ws.Range("found").End(xlDown).Row
Set rgBottomRight = ws.Cells(lLastRow, rgTopLeft.Offset(0, 3).Column)
ws.Range(rgTopLeft, rgBottomRight).ClearContents
Set rgTopLeft = Nothing
Set rgBottomRight = Nothing
Set ws = Nothing
End Sub