so hier mal eine update, da war irgendwie ne zeile verschwunden

Sub Findezellen()
   Dim f As Range, a As String
   Dim lstart As Long, lend As Long, 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
    If Not f Is Nothing Then                                  'wenn gefunden
        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