mehrere Spalten untereinander ohne Doppler

Sub Column()
Dim vArr, i As Long, j As Long, oDic As Object, oKey
Set oDic = CreateObject("scripting.dictionary")
vArr = Cells(1, 1).CurrentRegion
For i = 2 To UBound(vArr)
For j = 4 To UBound(vArr, 2)
oDic(vArr(i, j)) = 0
Next
Next
i = 0
ReDim vArr(1 To oDic.Count, 1 To 1)
For Each oKey In oDic
i = i + 1
vArr(i, 1) = oKey
Next
With Sheets("TA_Column")
.Columns(4).ClearContents
.Cells(1, 1).Resize(oDic.Count) = vArr
Sheets("TA_Column").Select
Columns(1).Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End With
End Sub