AW: ComboBox Abhängig von Textbox füllen
13.01.2021 12:03:56
Textbox
Hallo Lidi
für das Formular brauchst du 4 Listenfelder und ein Textfeld in deinem Formular.
Das Tabellenblatt aus dem die Daten entnommen sind habe ich "Daten" genannt.
Dann folgenden Code:
Private Sub ListBox1_Click()
Dim wb As Workbook
Dim wks_Daten As Worksheet
Dim objDictionary As Object
Dim lz, Zaehler As Long
Dim i, e As Integer
Dim rng As Variant
Dim arr() As Variant
Dim PLZ As Long
Dim Ort As String
Set wb = ThisWorkbook
Set wks_Daten = wb.Worksheets("Daten")
Set objDictionary = CreateObject("Scripting.Dictionary")
lz = wks_Daten.Cells(Rows.Count, 2).End(xlUp).Row
For intListBox = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(intListBox) Then
PLZ = ListBox1.List(intListBox, 0)
End If
Next
Me.ListBox2.ColumnCount = 1
Me.ListBox2.ColumnWidths = "50"
Einträge = Me.ListBox2.ListCount
'Die Listeneinträge aus ListBox2 löschen
Me.ListBox2.Clear
Me.ListBox2.ColumnCount = 1
Me.ListBox2.ColumnWidths = "70"
With wks_Daten
lz = .Cells(Rows.Count, 2).End(xlUp).Row
rng = .Range("B2:B" & lz)
End With
For Zaehler = 2 To lz 'LBound(rng) + 1 To UBound(rng) + 1
If wks_Daten.Cells(Zaehler, 1) = PLZ Then
' Eintrag wird nur übernommen wenn er im DictionaryObject noch nicht enthalten ist
objDictionary(rng(Zaehler - 1, 1)) = 0
End If
Next
' Werte in ein Array übergeben
If objDictionary.Count = 0 Then
ReDim arr(1)
Else
ReDim arr(objDictionary.Count - 1)
End If
arr = objDictionary.keys
e = 0
For i = LBound(arr) To UBound(arr)
Me.ListBox2.AddItem " "
Me.ListBox2.List(e, 0) = arr(i)
e = e + 1
Next i
End Sub
Private Sub ListBox2_Click()
Dim wb As Workbook
Dim wks_Daten As Worksheet
Dim objDictionary As Object
Dim lz, Zaehler As Long
Dim i, e As Integer
Dim rng As Variant
Dim arr() As Variant
Dim PLZ, Ort As String
Set wb = ThisWorkbook
Set wks_Daten = wb.Worksheets("Daten")
Set objDictionary = CreateObject("Scripting.Dictionary")
lz = wks_Daten.Cells(Rows.Count, 3).End(xlUp).Row
For intListBox = 0 To ListBox2.ListCount - 1
If ListBox2.Selected(intListBox) Then
Ort = ListBox2.List(intListBox, 0)
End If
Next
Me.ListBox3.ColumnCount = 1
Me.ListBox3.ColumnWidths = "50"
Einträge = Me.ListBox2.ListCount
'Die Listeneinträge aus ListBox2 löschen
Me.ListBox3.Clear
Me.ListBox2.ColumnCount = 1
Me.ListBox2.ColumnWidths = "70"
With wks_Daten
lz = .Cells(Rows.Count, 2).End(xlUp).Row
rng = .Range("C2:C" & lz)
End With
' Schleife über alle Werte des Bereichs
For Zaehler = 2 To lz 'LBound(rng) + 1 To UBound(rng) + 1
If wks_Daten.Cells(Zaehler, 2) = Ort Then
' Eintrag wird nur übernommen wenn er im DictionaryObject noch nicht enthalten ist
objDictionary(rng(Zaehler - 1, 1)) = 0
End If
Next
' Werte in ein Array übergeben
If objDictionary.Count = 0 Then
ReDim arr(1)
Else
ReDim arr(objDictionary.Count - 1)
End If
arr = objDictionary.keys
arr = objDictionary.keys
e = 0
For i = LBound(arr) To UBound(arr)
Me.ListBox3.AddItem " "
Me.ListBox3.List(e, 0) = arr(i)
e = e + 1
Next i
End Sub
Private Sub ListBox3_Click()
Dim wb As Workbook
Dim wks_Daten As Worksheet
Dim objDictionary As Object
Dim lz, Zaehler As Long
Dim i, e As Integer
Dim rng As Variant
Dim arr() As Variant
Dim PLZ, Ort, Straße As String
Set wb = ThisWorkbook
Set wks_Daten = wb.Worksheets("Daten")
Set objDictionary = CreateObject("Scripting.Dictionary")
lz = wks_Daten.Cells(Rows.Count, 3).End(xlUp).Row
For intListBox = 0 To ListBox3.ListCount - 1
If ListBox3.Selected(intListBox) Then
Straße = ListBox3.List(intListBox, 0)
End If
Next
Me.ListBox4.ColumnCount = 1
Me.ListBox4.ColumnWidths = "10"
Einträge = Me.ListBox3.ListCount
'Die Listeneinträge aus ListBox4 löschen
Me.ListBox4.Clear
With wks_Daten
lz = .Cells(Rows.Count, 3).End(xlUp).Row
rng = .Range("D2:D" & lz)
End With
' Schleife über alle Werte des Bereichs
For Zaehler = 2 To lz 'LBound(rng) + 1 To UBound(rng) + 1
If wks_Daten.Cells(Zaehler, 3) = Straße Then
' Eintrag wird nur übernommen wenn er im DictionaryObject noch nicht enthalten ist
objDictionary(rng(Zaehler - 1, 1)) = 0
End If
Next
' Werte in ein Array übergeben
If objDictionary.Count = 0 Then
ReDim arr(1)
Else
ReDim arr(objDictionary.Count - 1)
End If
arr = objDictionary.keys
arr = objDictionary.keys
e = 0
For i = LBound(arr) To UBound(arr)
Me.ListBox4.AddItem " "
Me.ListBox4.List(e, 0) = arr(i)
e = e + 1
Next i
End Sub
Private Sub ListBox4_Click()
Dim wb As Workbook
Dim wks_Daten As Worksheet
Dim objDictionary As Object
Dim lz, Zaehler As Long
Dim i, e As Integer
Dim rng As Variant
Dim arr() As Variant
Dim Ort, Straße, HsNr As String
Dim PLZ As Long
Set wb = ThisWorkbook
Set wks_Daten = wb.Worksheets("Daten")
Set objDictionary = CreateObject("Scripting.Dictionary")
lz = wks_Daten.Cells(Rows.Count, 3).End(xlUp).Row
For intListBox = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(intListBox) Then
PLZ = ListBox1.List(intListBox, 0)
End If
Next
For intListBox = 0 To ListBox2.ListCount - 1
If ListBox2.Selected(intListBox) Then
Ort = ListBox2.List(intListBox, 0)
End If
Next
For intListBox = 0 To ListBox3.ListCount - 1
If ListBox3.Selected(intListBox) Then
Straße = ListBox3.List(intListBox, 0)
End If
Next
For intListBox = 0 To ListBox4.ListCount - 1
If ListBox4.Selected(intListBox) Then
HsNr = ListBox4.List(intListBox, 0)
End If
Next
For i = 2 To lz
With wks_Daten
If (.Cells(i, 1) = CLng(PLZ) And .Cells(i, 2) = Ort And .Cells(i, 3) = Straße And . _
Cells(i, 4) = CStr(HsNr)) Then
Me.TextBox1 = .Cells(i, 5)
End If
End With
Next
End Sub
Private Sub UserForm_Initialize()
Dim wb As Workbook
Dim wks_Daten As Worksheet
Dim objDictionary As Object
Dim lz, Zaehler As Long
Dim i, e As Integer
Dim rng As Variant
Dim arr() As Variant
Set wb = ThisWorkbook
Set wks_Daten = wb.Worksheets("Daten")
Set objDictionary = CreateObject("Scripting.Dictionary")
lz = wks_Daten.Cells(Rows.Count, 1).End(xlUp).Row
Me.ListBox1.ColumnCount = 1
Me.ListBox1.ColumnWidths = "50"
With wks_Daten
lz = .Cells(Rows.Count, 1).End(xlUp).Row
rng = .Range("A2:A" & lz)
End With
' Schleife über alle Werte des Bereichs
For Zaehler = LBound(rng) + 1 To UBound(rng) + 1
If wks_Daten.Cells(Zaehler, 1) "" Then
' Eintrag wird nur übernommen wenn er im DictionaryObject noch nicht enthalten ist
objDictionary(rng(Zaehler - 1, 1)) = 0
End If
Next
' Werte in ein Array übergeben
ReDim arr(objDictionary.Count - 1)
arr = objDictionary.keys
ReDim arrDaten(objDictionary.Count, 2)
e = 0
For i = LBound(arr) To UBound(arr)
Me.ListBox1.AddItem " "
Me.ListBox1.List(e, 0) = arr(i)
e = e + 1
Next i
End Sub
Ich hoffe, es ist das, was du wolltest?
Gruß Oisse