Sub Runa()
Dim StartRow As Long: StartRow = 5
Dim LastRow As Long
Dim Name As String: Name = "*" & Cells(3, 1).Value & "*"
Application.ScreenUpdating = False
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
If LastRow > StartRow Then Range(Cells(StartRow, 1), Cells(LastRow, 2)).Clear
With Sheets("Отчёт")
For I = 1 To .Cells(Rows.Count, 1).End(xlUp).Row
If .Cells(I, 1).Value Like Name Then
Range("A" & StartRow + I - 1 & ":B" & StartRow + I - 1).Value = .Range("A" & I & ":B" & I).Value
End If
Next I
End With
With Range("A" & StartRow & ":B" & (StartRow + I - 2))
.WrapText = True
.Borders.LineStyle = 1
End With
Application.ScreenUpdating = True
End Sub