Sub Perenos()
Dim txt As String
Dim FoundFirma As Range
Dim i As Integer
Dim j As Integer
With Worksheets("Лист1")
      txt = "<> """
  For i = 3 To Cells(Rows.Count, "A").End(xlUp).Row
    For j = 1 To Len(Cells(i, "A"))
        Cells(i, "A") = Replace(Cells(i, "A"), Mid(txt, j, 1), "")
    Next
  Next
  For i = 4 To .Cells(.Rows.Count, "A").End(xlUp).Row
    For j = 1 To Len(Cells(i, "A"))
        .Cells(i, "A") = Replace(.Cells(i, "A"), Mid(txt, j, 1), "")
    Next
  Next
  For i = 3 To Cells(Rows.Count, "A").End(xlUp).Row
      Set FoundFirma = .Columns(1).Find(Cells(i, "A"), , xlValues)
      If Not FoundFirma Is Nothing Then
        .Range("B" & FoundFirma.Row & ":E" & FoundFirma.Row).Copy Cells(i, "B")
      End If
  Next
End With
End Sub