'На лист вставить первую пустую строку
Sub Poisk_tire()
Dim Found_tire As Range
Dim FAdr As String
Dim fRow As Long
Dim eRow As Long
Dim iLastRow As Long
   iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
  Set Found_tire = Columns("A").Find("—", , xlValues, xlPart)
    If Not Found_tire Is Nothing Then
      FAdr = Found_tire.Address
      Do
        fRow = Found_tire.Row
        Set Found_tire = Columns("A").FindNext(Found_tire)
        eRow = Found_tire.Row
        If eRow <> 2 Then
          Range("A" & fRow + 1 & ":A" & eRow - 1).Copy
        Else
          Range("A" & fRow + 1 & ":A" & iLastRow).Copy
        End If
        Range("B" & fRow).PasteSpecial xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
      Loop While Found_tire.Address <> FAdr
    End If
End Sub