den folgenden Code habe ich hier aus dem Forum erhalten. Er funktioniert auch absolut tadellos -hinter einem UF mit 3 Comboboxes-. Mein Versuch, nun auf eine vierte Combobox auszuweiten, mit Bezug auf Spalte G, ist jämmerlich gescheitert. Es erscheint nun eine Fehlermeldung -Typen unverträglich-; Was müßte ich noch im Code verändern bzw. was habe ich falsch gemacht? - Danke schon jetzt für die Rückmeldungen.
Gruß - Wolfgang
Option Explicit
Private shGrunddaten As Worksheet, shErgebnis As Worksheet
Private Sub prcFill_Combobox1()
Dim i As Long, ii As Integer, inList As Boolean, c As Range
'Funktion: ComboBox1 Spalte L
With ComboBox1
'.Clear
.ListRows = 0
.AddItem "(Alle)"
.AddItem "(Leere)"
.AddItem "(nicht Leere)"
.AddItem ""
With Sheets("Grunddaten")
i = .UsedRange.Row + .UsedRange.Rows.Count - 1
End With
For Each c In Sheets("Grunddaten").Range("L2:L" & Format(i, "0"))
If c.Text "" Then
inList = False
For ii = 0 To .ListCount - 1
If .List(ii) = c.Text Then
inList = True
Exit For
End If
Next ii
If Not inList Then .AddItem c.Text
End If
Next c
SortCombobox ComboBox1
End With
End Sub
Private Sub prcFill_Combobox2()
Dim i As Long, ii As Integer, inList As Boolean, c As Range
'Funktion: ComboBox2 Spalte O
With ComboBox2
.ListRows = 0
With Sheets("Grunddaten")
i = .UsedRange.Row + .UsedRange.Rows.Count - 1
End With
For Each c In Sheets("Grunddaten").Range("O2:O" & Format(i, "0"))
If c.Text "" Then
inList = False
For ii = 0 To .ListCount - 1
If .List(ii) = c.Text Then
inList = True
Exit For
End If
Next ii
If Not inList Then .AddItem c.Text
End If
Next c
SortCombobox ComboBox2, bolNumeric:=True
End With
End Sub
Private Sub prcFill_Combobox3()
Dim i As Long, ii As Integer, inList As Boolean, c As Range
'Funktion: ComboBox3 Spalte I
With ComboBox3
.ListRows = 0
.Clear
With shGrunddaten
i = .UsedRange.Row + .UsedRange.Rows.Count - 1
End With
For Each c In shGrunddaten.Range("I2:I" & Format(i, "0"))
If c.Text "" Then
inList = False
For ii = 0 To .ListCount - 1
If .List(ii) = c.Text Then
inList = True
Exit For
End If
Next ii
If Not inList Then .AddItem c.Text
End If
Next c
SortCombobox ComboBox3, bolNumeric:=True
End With
End Sub
Private Sub prcFill_Combobox4()
Dim i As Long, ii As Integer, inList As Boolean, c As Range
'Funktion: ComboBox3 Spalte I
With ComboBox4
.ListRows = 0
.Clear
With shGrunddaten
i = .UsedRange.Row + .UsedRange.Rows.Count - 1
End With
For Each c In shGrunddaten.Range("G2:G" & Format(i, "0"))
If c.Text "" Then
inList = False
For ii = 0 To .ListCount - 1
If .List(ii) = c.Text Then
inList = True
Exit For
End If
Next ii
If Not inList Then .AddItem c.Text
End If
Next c
SortCombobox ComboBox4, bolNumeric:=True
End With
End Sub
Private Sub cmdExtrahieren_Click()
Dim sh As Worksheet
Dim maxID As Integer, gZeile As Long, eZeile As Long, cnt As Long
Dim newErgebnis As Boolean
'Zeilen durchsuchen und in neuen Blatt einfügen
For gZeile = 2 To shGrunddaten.UsedRange.Row + shGrunddaten.UsedRange.Rows.Count - 1 ' _
Start-Zeile ggf. anpassen
If (shGrunddaten.Range("L" & gZeile).Text = ComboBox1.Text _
Or (shGrunddaten.Range("L" & gZeile).Text = "" And ComboBox1.Text = "(Leere)") _
_
Or (shGrunddaten.Range("L" & gZeile).Text "" And ComboBox1.Text = "(nicht _
Leere)") _
Or ComboBox1.Text = "(Alle)") _
And _
(ComboBox2.Text = "" Or shGrunddaten.Range("O" & gZeile).Text = ComboBox2. _
Text) _
And _
(ComboBox3.Text = "" Or shGrunddaten.Range("I" & gZeile).Text = ComboBox3. _
Text) _
And _
(ComboBox4.Text = "" Or shGrunddaten.Range("G" & gZeile).Text = ComboBox4. _
Text) Then
If Not newErgebnis Then
With shErgebnis
.Visible = xlSheetVisible
cnt = .UsedRange.Row + .UsedRange.Rows.Count - 1
eZeile = 2 '1. Zeile in die Daten kopiert werden sollen - _
ggf anpassen!!!!!
If cnt >= eZeile Then
' 'Altdaten im Ergebnisblatt löschen
.Range(.Rows(eZeile), .Rows(cnt)).Delete shift:=xlShiftUp
End If
End With
cnt = 0
newErgebnis = True
End If
shErgebnis.Rows(eZeile).Value = shGrunddaten.Rows(gZeile).Value
eZeile = eZeile + 1: cnt = cnt + 1
End If
Next gZeile
If cnt Then
shErgebnis.Activate
MsgBox "Es wurden " & cnt & " Datensätze nach '" & shErgebnis.Name & "' extrahiert!" _
, _
vbInformation, "Extrahieren"
Sheets("Start").Activate
Unload Me
Else
MsgBox "Es konnten keine entsprechenden Datensätze gefunden werden", vbInformation, _
_
"Extrahieren"
End If
End Sub
Private Sub SortCombobox(ComboboxObj As ComboBox, Optional bolNumeric As Boolean)
'bolNumeric - wenn True, dann wird die Auswahlliste nummerisch sortiert
Dim a As Long, b As Long, sTemp, vWerta, vWertb
With ComboboxObj
'Combobox sortieren :
For a = 0 To .ListCount - 1
vWerta = .List(a)
If bolNumeric = True Then vWerta = IIf(IsNumeric(.List(a)), CDbl(.List(a)), .List(a) _
)
For b = 0 To a - 1
vWertb = .List(b)
If bolNumeric = True Then vWertb = IIf(IsNumeric(.List(b)), CDbl(.List(b)), . _
List(b))
If vWertb > vWerta Then
sTemp = .List(b)
.List(b) = .List(a)
.List(a) = sTemp
End If
Next b
Next a
End With
End Sub
Private Sub ComboBox1_DropButtonClick()
'prcFill_Combobox1
End Sub
Private Sub ComboBox2_DropButtonClick()
'prcFill_Combobox2
End Sub
Private Sub ComboBox3_DropButtonClick()
'prcFill_Combobox3
End Sub
Private Sub CommandButton1_Click()
Unload Me
End Sub
Private Sub UserForm_Initialize()
Set shGrunddaten = Sheets("Grunddaten")
Set shErgebnis = Sheets("Ergebnis")
prcFill_Combobox1
prcFill_Combobox2
prcFill_Combobox3
prcFill_Combobox4
End Sub