AW: Auswahlliste für Combobox
17.05.2011 16:49:47
fcs
Hallo Ingo,
so ein Code ist nicht ganz trivial. Insbesondere, wenn die Randbedingungen entsprechend zahlreich sind.
Über die Parameter der Function "ListeErstellen" kann festgelegt werden, welche Daten in die Auswahlliste der ComboBox übernommen werden sollen.
Gruß
Franz
'Diese Prozeduren müssen im Code-Modul des Objekts mit der Combobox stehen (Tabelle oder _
Userform)
Sub Combobox1_Fuellen()
'Beispiel für Axtive-X-Combobox auf Tabellenblatt oder Userform
Me.ComboBox1.List = ListeErstellen(wksQuelle:=Worksheets("Tabelle1"), Spalte:=8, _
Doppelte:=False, Zeile1:=2, lFormat:=2)
End Sub
Sub DropDown_Fuellen()
'Beispiel für DropDown aus Formular-Steuerelemente auf Tabellenblatt
Dim oShape As Shape, aData, ii As Long
Set oShape = Me.Shapes("DropDown 6")
aData = ListeErstellen(wksQuelle:=Worksheets("Tabelle1"), Spalte:=8, _
Doppelte:=False, Zeile1:=2, lFormat:=2)
With oShape.ControlFormat
.RemoveAllItems
For ii = LBound(aData) To UBound(aData)
.AddItem aData(ii)
Next
End With
End Sub
'### Diese Prozeduren sollten in einem allgemeinen Modul eingefügt werden ###
Function ListeErstellen(wksQuelle As Worksheet, Spalte As Long, _
Optional Doppelte As Boolean = False, _
Optional Zeile1 As Long = 1, _
Optional lFormat As Long = 0, _
Optional bBlank As Boolean = False) As Variant
'Erstellt eine 1-spaltige Liste der Eintrage in der Spalte gemäß gewählten Optionen
'wksQuelle: Tabelle aus der Daten ausgelesen werden sollen
'Spalte: Nummer der Spalte aus der Werte ausgelesen werden sollen
'Doppelte: Wenn True, dann werden doppelte in Liste aufgenommen
'Zeile1: Zeile ab der Werte eingelesen werden sollen
'lFormat: 0 = Variant(beliebig), _
1 = nummerisch, _
2 = Datum, _
3 = Text(Zelle wie formatiert)
'bBlank: Wenn True, dann werden Leerzellen in Liste aufgenommen
Dim arrListe(), ii As Long, Zeile As Long
Dim oCollection As New Collection
On Error GoTo Fehler
With wksQuelle
ii = 0
'Werte aus Spalte einlesen in Datenarray
For Zeile = Zeile1 To .Cells(.Rows.Count, Spalte).End(xlUp).Row
If bBlank = False And IsEmpty(.Cells(Zeile, Spalte)) Then GoTo Next_Zeile
Select Case lFormat
Case 0 'Variant (beliebige) Werte
If Doppelte = False Then oCollection.Add Item:=.Cells(Zeile, Spalte), _
Key:=CStr(.Cells(Zeile, Spalte))
ii = ii + 1
ReDim Preserve arrListe(1 To ii)
arrListe(ii) = .Cells(Zeile, Spalte)
Case 1 'nummerische Werte
If IsNumeric(.Cells(Zeile, Spalte)) Then
If Doppelte = False Then oCollection.Add Item:=.Cells(Zeile, Spalte), _
Key:=CStr(.Cells(Zeile, Spalte))
ii = ii + 1
ReDim Preserve arrListe(1 To ii)
arrListe(ii) = .Cells(Zeile, Spalte).Value
End If
Case 2 'Datums-Werte
If IsDate(.Cells(Zeile, Spalte)) Then
If Doppelte = False Then oCollection.Add Item:=.Cells(Zeile, Spalte), _
Key:=Format(.Cells(Zeile, Spalte), "YYYY-MM-DD hhmmss")
ii = ii + 1
ReDim Preserve arrListe(1 To ii)
arrListe(ii) = .Cells(Zeile, Spalte).Value
End If
Case 3 'Textwerte, Zellinhalte wie formatiert
If Doppelte = False Then oCollection.Add Item:=.Cells(Zeile, Spalte), _
Key:=.Cells(Zeile, Spalte).Text
ii = ii + 1
ReDim Preserve arrListe(1 To ii)
arrListe(ii) = .Cells(Zeile, Spalte).Text
Case Else
MsgBox "Für ""lFormat"" wurde falscher Parameter-Wert übergeben!"
ListeErstellen = Array("")
GoTo Fehler
End Select
Next_Zeile:
Next
End With
If ii > 0 Then
'Liste sortieren
Call QuickSort(arrListe)
ListeErstellen = arrListe
Else
ListeErstellen = Array("")
MsgBox "Es wurden keine passenden Einträge gefunden"
End If
Fehler:
With Err
Select Case .Number
Case 0
Case 457 'Doppeltes Element in Collection
Resume Next_Zeile
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End Select
End With
Erase arrListe
Set oCollection = Nothing
End Function
Sub QuickSort(ByRef VA_array, Optional V_Low1, Optional V_high1)
On Error Resume Next
Dim V_Low2, V_high2, V_loop As Integer
Dim V_val1, V_val2 As Variant
If IsMissing(V_Low1) Then
V_Low1 = LBound(VA_array, 1)
End If
If IsMissing(V_high1) Then
V_high1 = UBound(VA_array, 1)
End If
V_Low2 = V_Low1
V_high2 = V_high1
V_val1 = VA_array((V_Low1 + V_high1) / 2)
While (V_Low2 V_val1 And _
V_high2 > V_Low1)
V_high2 = V_high2 - 1
Wend
If (V_Low2 V_Low1) Then Call _
QuickSort(VA_array, V_Low1, V_high2)
If (V_Low2
