AW: Spaltenwerte in Array einlesen sofern diese ...
23.09.2009 21:04:42
Josef
Hallo Peter,
probier mal.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub Namen()
Dim varNames As Variant, varResult() As Variant
Dim lngLast As Long, lngIndex As Long, lngC As Long
With Sheets("Export1")
lngLast = .Cells(Rows.Count, 2).End(xlUp).Row
varNames = UniqueList(.Range("B2:B" & CStr(lngLast)))
End With
For lngIndex = 0 To UBound(varNames)
If InStr(1, varNames(lngIndex), ",") > 0 Then
Redim Preserve varResult(lngC)
varResult(lngC) = varNames(lngIndex)
lngC = lngC + 1
End If
Next
If lngC > 0 Then
With Sheets("Mitarbeiter")
.Range("B2:B" & CStr(lngC + 1)) = Application.Transpose(varResult)
End With
End If
End Sub
Function UniqueList(Matrix As Range, Optional Sorted As Boolean = True) As Variant
Dim objDic As Object, rng As Range, varTmp() As Variant
Set objDic = CreateObject("Scripting.Dictionary")
For Each rng In Matrix
If rng.Value <> "" Then objDic(rng.Value) = 0
Next
varTmp = objDic.keys
If Sorted Then QuickSort varTmp
UniqueList = varTmp
Set objDic = Nothing
End Function
Private Sub QuickSort(data() As Variant, Optional UG, Optional OG)
Dim P1&, P2&, T1 As Variant, T2 As Variant
UG = IIf(IsMissing(UG), LBound(data), UG)
OG = IIf(IsMissing(OG), UBound(data), OG)
P1 = UG
P2 = OG
T1 = data((P1 + P2) / 2)
Do
Do While (data(P1) < T1)
P1 = P1 + 1
Loop
Do While (data(P2) > T1)
P2 = P2 - 1
Loop
If P1 <= P2 Then
T2 = data(P1)
data(P1) = data(P2)
data(P2) = T2
P1 = P1 + 1
P2 = P2 - 1
End If
Loop Until (P1 > P2)
If UG < P2 Then QuickSort data, UG, P2
If P1 < OG Then QuickSort data, P1, OG
End Sub
Gruß Sepp