versuchs mal damit. die 1 wird in Spalte B gesucht, eingefügt wird ab Spalte 4

Sub Findezellen()
   Dim f As Range, a As String
   Dim lstart As Long
   Dim lend As Long
   Dim col As Long, cnt As Long, loletzte As Long
   col = 4                                                  'startspalte zum Einfügen
   loletzte = Range("B1").End(xlDown).Row                   'letzte benutzte Zeile in Spalte B
   
   With Range("B1:B" & loletzte)
      Set f = .Find(what:=1, LookIn:=xlValues, lookat:=xlWhole) 'suche nach 1 in Spalte B
          a = f.Address                                         'Adresse für Schleifenabbruch merken
         lstart = f.Row                                         'Zeilennummer merken
         Do
            Set f = .FindNext(f)                                'nächsten wert 1 suchen
            If Not f Is Nothing Then
              
              lend = f.Row                                       'zeilennummer merken
              If lend < lstart Then                              'wenn suche von vorne beginnt
                If lstart < loletzte Then                        'wenn nach der letzten 1 noch werte sind
                  Cells(2, col + cnt).Resize(loletzte - lstart, 2).Value = _
                        Cells(lstart, 2).Resize(loletzte - lstart, 2).Value
                Else
                  Exit Sub
                End If
              Else
                'kopieren des Wertebereiches
                Cells(2, col + cnt).Resize(lend - lstart, 2).Value = _
                        Cells(lstart, 2).Resize(lend - lstart, 2).Value
                cnt = cnt + 2     ' Spaltenzähler hochsetzen
                lstart = f.Row     'zeilennumer auf nächsten Bereich setzen
              End If
              
            End If
         Loop While f.Address <> a  'Schleifen Abbruch Bedingung
      End If
   End With
  
End Sub

Gruß

rb