AW: Gespendet
30.01.2019 20:14:44
Nepumuk
Hallo Helmut,
vielen Dank für die Spende. Kinder sind mir eine Herzensangelegenheit.
Und weil du so schnell warst habe ich auch Gas gegeben:
Option Explicit
Private Sub ComboBox1_Change()
Dim objFindCell As Range, objCell As Range
Dim strFirstAddress As String
'Listbox2 loeschen da sich der Wert der Combobox geaendert hat
Call ListBox2.Clear
'Pruefen ob eine Leiterlaenge ausgewaehlt wurde denn das Ereignis
'wird auch durch das Loeschen der Combobox ausgeloest
If ComboBox1.ListIndex >= 0 Then
'Verweis auf die Spalte 14 in der Tabelle 'Datenbank1' oeffnen
With WksDB1.Columns(14)
'Suche nach dem Ausgewaehlten Wert von Listbox1
Set objFindCell = .Find(What:=ListBox1.Text, After:=.Cells(1, 1), _
LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
'Wenn der Wert gefunden wurde
If Not objFindCell Is Nothing Then
'Adresse der Fundstelle merken
strFirstAddress = objFindCell.Address
'Schleife beginnen
Do
'Schleife ueber alle Einzelzellen des verbundenen Bereiches
For Each objCell In objFindCell.MergeArea
'Wenn der Wert in der Zelle dem ausgewaehlten Wert in der Combobox entspricht
If objCell.Offset(0, 3).Value = Clng(ComboBox1.Value) Then
'Verweis auf die Listbox oeffnen
With ListBox2
'Leere Zeile hinzufuegen
Call .AddItem
'Die gewuenschten Werte dieser Zeile uebergeben
.List(.ListCount - 1, 0) = objCell.Offset(0, 3).Value
.List(.ListCount - 1, 1) = objCell.Offset(0, 5).Value
.List(.ListCount - 1, 2) = objCell.Offset(0, 7).Value
.List(.ListCount - 1, 3) = objCell.Offset(0, -7).Value
End With
End If
Next
'Naechsten Eintrag suchen
Set objFindCell = .FindNext(After:=objFindCell)
'Wenn kein Wert gefunden wurde Schleife verlassen
If objFindCell Is Nothing Then Exit Do
'Wenn die erste Fundstelle wieder gefunden wurde Schleife verlassen
Loop Until objFindCell.Address = strFirstAddress
'Objektvariable resetten
Set objFindCell = Nothing
'In das Label2 die Anzahl der gefundenen Leitern eintragen
Label2.Caption = CStr(ListBox2.ListCount) & " Leitern vorhanden"
End If
End With
End If
End Sub
Private Sub CommandButton1_Click()
'Userform schliessen
Call Unload(Object:=Me)
End Sub
Private Sub ListBox1_Change()
Dim objFindCell As Range, objCell As Range
Dim objDictionary As Object
Dim strFirstAddress As String
'Listbox2 loeschen
Call ListBox2.Clear
'Combobox1 loeschen
Call ComboBox1.Clear
'Label2 loeschen
Label2.Caption = vbNullString
'Verweis auf die Spalte 14 in der Tabelle 'Datenbank1' oeffnen
With WksDB1.Columns(14)
'Suche nach dem Ausgewaehlten Wert von Listbox1
Set objFindCell = .Find(What:=ListBox1.Value, After:=.Cells(1, 1), _
LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
'Wenn der Wert gefunden wurde
If Not objFindCell Is Nothing Then
'Adresse der Fundstelle merken
strFirstAddress = objFindCell.Address
'Dictionary initialisieren ein Dictionary ist ein Array mit einem Wert und einem eindeutigen Schluessel
Set objDictionary = CreateObject(Class:="Scripting.Dictionary")
'Schleife beginnen
Do
'Schleife ueber alle Einzelzellen des verbundenen Bereiches
For Each objCell In objFindCell.MergeArea
'Verweis auf die Zelle drei Spalten nach rechts oeffnen
With objCell.Offset(0, 3)
'Wenn die Zelle nicht leer ist dann dem Dictionary mit dem
'Zellwert als Schluessel einen leeren String zuweisen
'Wenn der Schluessel noch nicht existiert wird er angelegt,
'wenn er schon existiert passiert nichts
If .Value <> vbNullString Then objDictionary(.Value) = vbNullString
End With
Next
'Naechsten Eintrag suchen
Set objFindCell = .FindNext(After:=objFindCell)
'Wenn kein Wert gefunden wurde Schleife verlassen
If objFindCell Is Nothing Then Exit Do
'Wenn die erste Fundstelle wieder gefunden wurde Schleife verlassen
Loop Until objFindCell.Address = strFirstAddress
'Der Combobox die Schlssel des Dictionary uebergeben
ComboBox1.List = objDictionary.Keys
'Eintraege der Combobox sortieren
Call QuickSort(0, ComboBox1.ListCount - 1, ComboBox1)
'Objektvariablen resetten
Set objDictionary = Nothing
Set objFindCell = Nothing
End If
End With
End Sub
Private Sub UserForm_Activate()
Dim avntValues As Variant, vntItem As Variant
Dim objDictionary As Object
'Verweis auf die Tabelle 'Datenbank1' oeffnen
With WksDB1
'Alle Werte ab Zeile 3 bis zur letzten benutzten Zeile der Spalte 14 in ein Aray einlesen
avntValues = .Range(.Cells(3, 14), .Cells(.Rows.Count, 14).End(xlUp)).Value
End With
'Dictionary initialisieren ein Dictionary ist ein Array mit einem Wert und einem eindeutigen Schluessel
Set objDictionary = CreateObject(Class:="Scripting.Dictionary")
'Schleife ueber alle Werte im Array
For Each vntItem In avntValues
'Wenn der Eintrag nicht leer ist dann dem Dictionary mit
'dem Arraywert als Schluessel einen leeren String zuweisen
'Wenn der Schluessel noch nicht existiert wird er angelegt,
'wenn er schon existiert passiert nichts
If Not IsEmpty(vntItem) Then objDictionary(vntItem) = vbNullString
Next
'Der Listbox1 die Schluessel des Dictionarys uebergeben
ListBox1.List = objDictionary.Keys
'Objektvariable resetten
Set objDictionary = Nothing
End Sub
Private Sub QuickSort(ByVal pvlngLBound As Long, ByVal pvlngUBound As Long, ByRef probjComboBox As MSForms.ComboBox)
'Eine Erklaerung des QuickSorts findest du hier: https://de.wikipedia.org/wiki/Quicksort
Dim lngIndex1 As Long, lngIndex2 As Long, vntBuffer As Variant, lngTemp As Long
lngIndex1 = pvlngLBound
lngIndex2 = pvlngUBound
With probjComboBox
lngTemp = Clng(.List((pvlngLBound + pvlngUBound) \ 2, 0))
Do
Do While Clng(.List(lngIndex1, 0)) < lngTemp
lngIndex1 = lngIndex1 + 1
Loop
Do While lngTemp < Clng(.List(lngIndex2, 0))
lngIndex2 = lngIndex2 - 1
Loop
If lngIndex1 <= lngIndex2 Then
vntBuffer = .List(lngIndex1, 0)
.List(lngIndex1, 0) = .List(lngIndex2, 0)
.List(lngIndex2, 0) = vntBuffer
lngIndex1 = lngIndex1 + 1
lngIndex2 = lngIndex2 - 1
End If
Loop Until lngIndex1 > lngIndex2
End With
If pvlngLBound < lngIndex2 Then Call QuickSort(pvlngLBound, lngIndex2, probjComboBox)
If lngIndex1 < pvlngUBound Then Call QuickSort(lngIndex1, pvlngUBound, probjComboBox)
End Sub
Gruß
Nepumuk
