Sub Sbor()
Dim FoundPart As Range
Dim WSH As Worksheet
Dim iLastRow As Long
Dim iLR As Long
    iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
        If iLastRow <> 1 Then Range("A2:E" & iLastRow).ClearContents
    For Each WSH In Worksheets  'цикл по всем листам книги
        If WSH.Name <> "сборка" Then
With WSH
Set FoundPart = .Rows(1).Find("партия", , xlValues, xlWhole)
    If Not FoundPart Is Nothing Then
      iLastRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
      iLR = .Cells(.Rows.Count, 2).End(xlUp).Row
      Cells(iLastRow, 1).Resize(iLR - 2) = .Name
      .Range("A3:B" & iLR).Copy Cells(iLastRow, 2)
      FoundPart.Offset(2).Resize(5, 2).Copy Cells(iLastRow, 4)
    End If
End With
        End If
    Next WSH
End Sub