AW: Listbox Einträge beim Laden Fehler
08.04.2020 19:36:33
Matthias
Moin!
Also da gab es jetzt ein paar Baustellen mehr. Zum Teil lag es an der column-Eigenschaft (mal wieder getarnt :-) ) und an der Übertragung der Daten. Du müsstest die beiden sub für die Suche und das Changeevent wie folgt ändern.
Bei txt_suche_change das hier:
Private Sub txt_Suche_Change()
Dim avntValues() As Variant, avntFilterValues() As Variant
Dim ialngIndex As Long, ialngCount As Long
Dim shQuelle As Worksheet
Dim strText As String
Dim letzteZeile As Long, letzteSpalte As Long, i As Long '****hinzugefügt
Set shQuelle = Sheets("Teilnehmer")
lst_Teilnehmer.Clear
With shQuelle
'***Änderung: avntValues ist jetzt ein Array über Spalte 1 bis 7 statt nur über Spalte 2:
letzteZeile = .Cells(.Rows.Count, 1).End(xlUp).Row
' Anzahl der anzuzeicgenden Spalten
letzteSpalte = 9
' Array beginnt Zeile 2 Spalte 1 endet in letzte Zeile und letzte Spalte
avntValues = .Range(.Cells(2, 1), .Cells(letzteZeile, letzteSpalte))
' Liste hat folgende Spaltenbreite
lst_Teilnehmer.ColumnWidths = "1cm;2cm;1,5cm;1,5cm;2,5cm;1cm;1cm;1cm;0cm"
strText = LCase$(Trim$(txt_Suche.Text))
If strText = vbNullString Then
'lst_Teilnehmer.List = avntValues
UserForm_Initialize
Else
For ialngIndex = LBound(avntValues) To UBound(avntValues, 1)
If LCase$(Left$(avntValues(ialngIndex, 2), Len(strText))) = strText Then
ialngCount = ialngCount + 1
ReDim Preserve avntFilterValues(1 To letzteSpalte, 1 To ialngCount) '***geä _
ndert
'ReDim Preserve avntFilterValues(1 To 2, 1 To ialngCount)
avntFilterValues(1, ialngCount) = avntValues(ialngIndex, 1)
avntFilterValues(2, ialngCount) = avntValues(ialngIndex, 2)
avntFilterValues(3, ialngCount) = avntValues(ialngIndex, 3)
avntFilterValues(4, ialngCount) = avntValues(ialngIndex, 4)
avntFilterValues(5, ialngCount) = avntValues(ialngIndex, 5)
avntFilterValues(6, ialngCount) = avntValues(ialngIndex, 6)
avntFilterValues(7, ialngCount) = avntValues(ialngIndex, 7)
avntFilterValues(8, ialngCount) = ""
avntFilterValues(9, ialngCount) = ialngIndex + 1
'avntFilterValues(8, ialngCount) = avntValues(ialngIndex, 16)
End If
Next
If ialngCount > 0 Then
lst_Teilnehmer.Column = avntFilterValues
Else
Call lst_Teilnehmer.AddItem("Kein Treffer")
End If
End If
End With
End Sub
Hier war das Problem, dass am Anfang an avntValues die Daten aus dem Blatt übergeben wurden. Da stand erst Spalten 7. Bei keinem TReffer, hätte er dann wieder diesen Bereich genommen und damit nur 7 Spalten gehabt. Zudem hatte der BEreich einen anderen INhalt als deine vorherige Liste. Dann musste man auch noch die zwei zusätzlichen Spalten füllen. Habe ich gemacht. Jetzt sollten da alle Daten passen.
Dann noch der Button suche
Private Sub btn_Suche_Click()
' Code aus j.hennekes.de/1228126.htm
Dim rngCell As Range
Dim strFirstAddress As String
With Worksheets("Teilnehmer").Range("B:B")
Me.lst_Teilnehmer.Clear
Set rngCell = .Find(Me.txt_Suche.Value, LookIn:=xlValues, lookat:=xlWhole)
If Not rngCell Is Nothing Then
strFirstAddress = rngCell.Address
Do
With Me.lst_Teilnehmer
'.ColumnCount = 7 'lieber weglassen und über die Eigenschaften der ListBox festlegen
.ColumnHeads = False
'.RowSource = "Teilnehmer!A2:P500"
.AddItem
.List(.ListCount - 1, 0) = rngCell.Offset(0, -1).Value
.List(.ListCount - 1, 1) = rngCell
.List(.ListCount - 1, 2) = rngCell.Offset(0, 1).Value
.List(.ListCount - 1, 3) = rngCell.Offset(0, 2).Value
.List(.ListCount - 1, 4) = rngCell.Offset(0, 3).Value
.List(.ListCount - 1, 5) = rngCell.Offset(0, 4).Value
.List(.ListCount - 1, 6) = rngCell.Offset(0, 5).Value
.List(.ListCount - 1, 7) = rngCell.Offset(0, 16).Value
.List(.ListCount - 1, 8) = rngCell.Row
.ColumnWidths = "1cm;2cm;1,5cm;1,5cm;2,5cm;1cm;1cm;1cm;0cm"
End With
Set rngCell = .FindNext(rngCell)
Loop While Not rngCell Is Nothing And rngCell.Address strFirstAddress
Else
MsgBox "Teilnehmer nicht gefunden", 48
End If
End With
End Sub
HIer stimmte die Zuordnung der Werte nicht. Außerdem wurden auch wieder nicht alle 9 Spalten befüllt. Damit kamen dann wieder Fehler.
Habe dann noch ein wenig gestest. Ändere die Sub hier auch mal.
Private Sub btn_Delete_Click()
Dim zeile As Long, zeileb As Long, spalte As Long
For zeile = lst_TN_Auswahl.ListCount - 1 To 0 Step -1
If Me.lst_TN_Auswahl.Selected(zeile) = True Then
For zeileb = 0 To Me.lst_Teilnehmer.ListCount - 1
If CLng(lst_TN_Auswahl.List(zeile, 8))
Damit wird beim Rückschreiben auch bei einer leeren Liste richtig eingefügt. Und nimm in der Sub Sub btn_ADD_Click() am Ende die Schleife raus. Da reicht das
Me.lst_Teilnehmer.RemoveItem (Me.lst_Teilnehmer.ListIndex)
Ansonsten schmeißt er dir bei einer gefilterten LIste alles raus. Wie gesagt, du hast dort nur eine Einfachauswahl drin. Die Schleife ist also unnötigt. Wenn du es aber auf Mehrfachauswahl setzt, könnten evtl. andere Makros nicht mehr passen.
Da ggf. nochmal Gedanken machen und schauen, wie es später sein soll. Das kann natürlich dazu führen, dass man Teile vom Code nochmal aufsetzen muss (wäre aber wohl nicht viel).
VG