Hallo,
ich würde gerne alle meine Spalten untereinander kopieren. Den passenden Code hatte ich mal im Internert gefunden. Da es in meinen Spalten aber auch leere Zellen gibt, die unbedingt mit kopiert werden müssen, haut dieser Code nicht mehr ganz hin. Gibt es da eine Möglichkeit diesen zu ergänzen?
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") 'Bereich der übernommen werden soll
Set rg2 = ws.Range("A2") 'erste Zelle wo die Auflistung beginnt
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
|