kleine Korrektur!
09.03.2019 18:14:17
Sepp
Hallo nochmal.
Modul Modul1
Option Explicit
Enum SORT_ORDER
Sort_Unsorted = 0
Sort_Ascending = 1
Sort_Descending = -1
End Enum
Sub oneColumn()
Dim varIn As Variant, varOut As Variant, lngLast As Long
With Sheets("Tabelle1") 'Tabellenname anpassen!
lngLast = lastCell("A:C")
varIn = .Range("A1:C" & CStr(lngLast))
varOut = Application.Transpose(toArrayUnique(varIn, Sort_Ascending))
.Range("D:D") = ""
.Range("D1").Resize(Ubound(varOut, 1), 1) = varOut
End With
End Sub
Private Function toArrayUnique(ByRef Field As Variant, Optional SortOrder As SORT_ORDER = Sort_Ascending) As Variant
Dim objArrayList As Object, varItem As Variant
Dim lngR As Long, lngC As Long
On Error GoTo ErrExit
Set objArrayList = CreateObject("System.Collections.Arraylist")
With objArrayList
For lngR = Lbound(Field, 1) To Ubound(Field, 1)
For lngC = Lbound(Field, 2) To Ubound(Field, 2)
varItem = Trim(Field(lngR, lngC))
If Len(varItem) And Not .Contains(varItem) Then .Add varItem
Next
Next
If SortOrder <> Sort_Unsorted Then .Sort
If SortOrder < Sort_Unsorted Then .Reverse
toArrayUnique = .toArray
End With
Exit Function
ErrExit:
toArrayUnique = -1
End Function
Private Function lastCell(ByVal RangeAddress As String, Optional ByVal lastRow As Boolean = True) As Long
Dim varLast As Variant
If lastRow Then
varLast = Evaluate("MAX(IF(" & RangeAddress & "<>"""",ROW(" & RangeAddress & ")))")
Else
varLast = Evaluate("MAX(IF(" & RangeAddress & "<>"""",COLUMN(" & RangeAddress & ")))")
End If
If IsError(varLast) Then
lastCell = -1
Else
lastCell = varLast
End If
End Function
VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media
Code erstellt und getestet in Office 16 - mit VBAHTML 12.6.0