Listbox "Format/Größe" spring ständig um
KLE
ich habe in einem Arbeitsblatt eine Listbox, welche auf einer Suchfunktion basierend Daten aus einem Datenblatt anzeigt. Um dem Formular optisch und der Lesbarkeit für den User gerecht zu werden, habe ich die Listbox eine bestimmte größe vergeben. Doch wenn die Prozedur des "Inhalte einlesens" abläuft, entscheidet sich die Listbox für ein eigenes Format/Größe?!?
D.h. mit jedem Aufruf der Prozedur sieht das Listfeld am Ende unterschiedlich in ihrer Größe aus. Meist immer kleiner werdend in der Breite und Höhe...
Woran kann es liegen und was kann man dagegen tun?
Hier mein Code...
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++'
' Suchtext-Eingabe führt unmittelbar zur Listenaktualisierung
Private Sub objTBSuche_Change()
Datensatzsuche
End Sub
Private Sub Datensatzsuche()
Dim sText As String
Dim ArrayData
Application.ScreenUpdating = False
sText = objTBSuche.Text
' Listenfeld formatieren und füllen
With objLBDaten
.ListFillRange = ""
.ColumnCount = 5
' Listenbereich übergeben (Suchfunktionsergebnis)
ArrayData = fncListe(sText)
' Wenn etwas gefunden wird - Liste anpassen, sonst leeren
If IsArray(ArrayData) Then
arrKontakte = arrListe
.List = fncListe(sText)
Else
.Clear
End If
' Listbox sortieren (Name - Spalte3)
'Listbox an Array übergeben
On Error GoTo Ende
ReDim arr(1 To objLBDaten.ListCount, 1 To objLBDaten.ColumnCount)
For i = 1 To objLBDaten.ListCount
For j = 1 To 5 ' alle 5 Spalten
arr(i, j) = objLBDaten.List(i - 1, j - 1)
Next j
Next i
' Sortieren Spalte 3
ArrK = Array(2)
'Sortieren
Call prcSort(ArrK, arr)
' Liste zurück geben
objLBDaten.List() = arr
' Listbox-Größe und Position anpassen
.ColumnWidths = "1 Pt;114,95 Pt;90 Pt;90 Pt;170 Pt"
.Height = 834
.Width = 485.25
.Top = 90
.Left = 966.75
End With
Ende:
' Info der Anzahl gefundener Datensätze
objLCount.Caption = objLBDaten.ListCount & " Datesnätze wurden gefunden."
Application.ScreenUpdating = True
End Sub
Dim oDaten1, oDaten2, oDaten3, oDaten4 As Object
Dim arrListe, NewArray()
Dim a As Long
With Worksheets("DB-Contacts")
a = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
If a = 1 Then
fncListe = arrListe
Exit Function
Else
Set oDaten1 = CreateObject("Scripting.dictionary")
Set oDaten2 = CreateObject("Scripting.dictionary")
Set oDaten3 = CreateObject("Scripting.dictionary")
Set oDaten4 = CreateObject("Scripting.dictionary")
arrListe = Worksheets("Daten").Range("A8:AV" & a)
For a = 1 To UBound(arrListe)
If InStr(LCase(arrListe(a, 48)), LCase(sText)) > 0 Then
oDaten1(arrListe(a, 1)) = arrListe(a, 6)
oDaten2(arrListe(a, 1)) = arrListe(a, 5)
oDaten3(arrListe(a, 1)) = arrListe(a, 9)
oDaten4(arrListe(a, 1)) = arrListe(a, 14)
End If
Next
If oDaten1.Count > 0 Then
arrListe = oDaten1.Keys
ReDim NewArray(UBound(arrListe), 4)
For a = LBound(arrListe) To UBound(arrListe)
NewArray(a, 0) = arrListe(a)
NewArray(a, 1) = oDaten1(arrListe(a))
NewArray(a, 2) = oDaten2(arrListe(a))
NewArray(a, 3) = oDaten3(arrListe(a))
NewArray(a, 4) = oDaten4(arrListe(a))
Next
fncListe = NewArray
End If
End If
End Function Vielen Dank für Eure Hilfe bereits an dieser Stelle ;o)
Gruß
KLE