Sub Поиск()
    
    Dim shSrc As Worksheet, shRes As Worksheet
    Dim lr As Long
    
    Application.ScreenUpdating = False
    Set shSrc = Worksheets("данные")
    Set shRes = Worksheets("поиск")
    lr = shRes.UsedRange.Row + shRes.UsedRange.Rows.Count - 1
    If lr > 6 Then
        shRes.Rows("7:" & lr).Delete
    End If
    Вспомогательная shSrc, shSrc.Columns("A:J"), shRes, 1
    Вспомогательная shSrc, shSrc.Columns("L:U"), shRes, 2
    Вспомогательная shSrc, shSrc.Columns("W:AF"), shRes, 3
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    MsgBox "Готово!", vbInformation

End Sub

Private Sub Вспомогательная(shSrc As Worksheet, rngSrc As Range, shRes As Worksheet, lngTableIndex As Long)
    
    Dim номер
    Dim arr(), lr As Long, i As Long
    
    lr = shSrc.Cells(shSrc.Rows.Count, rngSrc.Columns(4).Column).End(xlUp).Row
    If lr < 3 Then
        Exit Sub
    End If
    arr() = rngSrc.Columns(4).Rows(1).Resize(lr).Value
    номер = shRes.Range("C2").Value
    lr = shRes.UsedRange.Row + shRes.UsedRange.Rows.Count
    For i = 3 To UBound(arr)
        If arr(i, 1) = номер Then
            rngSrc.Rows(i).Copy
            shRes.Cells(lr, "A").PasteSpecial (xlPasteFormats)
            shRes.Cells(lr, "A").PasteSpecial (xlPasteValues)
            shRes.Cells(lr, "K").Value = lngTableIndex
            lr = lr + 1
        End If
    Next i

End Sub