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
loletzte = Range(
"B1"
).
End
(xlDown).Row
With
Range(
"B1:B"
& loletzte)
Set
f = .Find(what:=1, LookIn:=xlValues, lookat:=xlWhole)
If
Not
f
Is
Nothing
Then
a = f.Address
lstart = f.Row
Do
Set
f = .FindNext(f)
If
Not
f
Is
Nothing
Then
lend = f.Row
If
lend < lstart
Then
If
lstart < loletzte
Then
Cells(2, col + cnt).Resize(loletzte - lstart, 2).Value = _
Cells(lstart, 2).Resize(loletzte - lstart, 2).Value
Else
Exit
Sub
End
If
Else
Cells(2, col + cnt).Resize(lend - lstart, 2).Value = _
Cells(lstart, 2).Resize(lend - lstart, 2).Value
cnt = cnt + 2
lstart = f.Row
End
If
End
If
Loop
While
f.Address <> a
End
If
End
With
End
Sub