Sub
untereinander()
Dim
ws
As
Worksheet
Dim
rg1
As
Range, rg2
As
Range, rg3
As
Range
Dim
v1, v2, n1, n2
As
Long
Dim
xAdr
As
String
n1 = -1
Set
ws = ActiveSheet
Set
rg1 = ws.Range(
"C2:Z20000"
)
Set
rg2 = ws.Range(
"A2"
)
rg2.Resize(151, 1).ClearContents
Set
rg3 = rg1.Find(
"*"
, ws.Range(
"Z20000"
), xlValues, xlPart, xlByRows, xlNext)
If
Not
(rg3
Is
Nothing
)
Then
xAdr = rg3.Address
Do
n1 = n1 + 1
rg2.Offset(n1, 0).Value = rg3.Value
Set
rg3 = rg1.FindNext(rg3)
Loop
While
xAdr <> rg3.Address
End
If
Set
rg3 =
Nothing
Set
rg2 =
Nothing
Set
rg1 =
Nothing
Set
ws =
Nothing
End
Sub
Vielen Dank im voraus