Hallo Boris,
anbei der Code
Sub ListboxFuellen()
Dim z As Long, lstZ As Long
Dim FirstAddress As String, Search As String
Dim Found As Range
If ThisWorkbook.CustomDocumentProperties("UserformStart") = 1 Then Exit Sub
If [AK65536] = "" Then
z = [AK65536].End(xlUp).Row
Else
z = 65536
End If
Search = cboStationNeu 'Wert aus Combobox in der Userform
If Search = "" Then Exit Sub
frmStationen.lstDaten.ColumnCount = 10
With ActiveSheet.Range("AK1:AK" & z)
Set Found = .Find(Search, lookat:=xlPart)
If Found Is Nothing Then
lstDaten.Clear
On Error Resume Next
With frmStationen.lstDaten
.AddItem Cells(1, 1)
.List(0, 1) = Cells(1, 3)
.List(0, 2) = Cells(1, 4)
.List(0, 3) = Cells(1, 37) & " / " & Cells(1, 14)
.List(0, 4) = Cells(1, 40)
.List(0, 5) = Cells(1, 43)
.List(0, 6) = Cells(1, 48)
.List(0, 7) = Cells(1, 8)
.List(0, 8) = Cells(1, 9)
.List(0, 9) = Cells(1, 44) & " / " & Cells(1, 45)
End With
On Error GoTo 0
Exit Sub
End If
lstDaten.Clear
FirstAddress = Found.Address
frmStationen.lstDaten.ColumnWidths = "2,3cm;2,3cm;2,3cm;9,0cm;2,3cm;2,3cm;9cm;2,3cm;3cm;4,5cm"
ReDim MyArray(0 To z, 0 To 9)
If chkFilter.Value = False Then
On Error Resume Next
MyArray(0, 0) = Cells(1, Found.Column - 36)
MyArray(0, 1) = Cells(1, Found.Column - 34)
MyArray(0, 2) = Cells(1, Found.Column - 33)
MyArray(0, 3) = Cells(1, Found.Column) & " / " & Cells(1, Found.Column - 23)
MyArray(0, 4) = Cells(1, Found.Column + 3)
MyArray(0, 5) = Cells(1, Found.Column + 6)
MyArray(0, 6) = Cells(1, Found.Column + 11)
MyArray(0, 7) = Cells(1, Found.Column - 29)
MyArray(0, 8) = Cells(1, Found.Column - 28)
MyArray(0, 9) = Cells(1, Found.Column + 7) & " / " & Cells(1, Found.Column + 8)
lstZ = lstZ + 1
MyArray(lstZ, 0) = Found.Offset(0, -36)
MyArray(lstZ, 1) = Found.Offset(0, -34)
MyArray(lstZ, 2) = Found.Offset(0, -33)
MyArray(lstZ, 3) = Found.Offset(0, 0) & " / " & Found.Offset(0, -23)
MyArray(lstZ, 4) = Format(Found.Offset(0, 3), "#0.000")
MyArray(lstZ, 5) = Format(Found.Offset(0, 6), "#0.000")
MyArray(lstZ, 6) = Found.Offset(0, 11)
MyArray(lstZ, 7) = Found.Offset(0, -29)
MyArray(lstZ, 8) = Found.Offset(0, -28)
MyArray(lstZ, 9) = Found.Offset(0, 7) & " / " & Found.Offset(0, 8)
lstZ = lstZ + 1
Do
Set Found = .FindNext(Found)
If Found.Address = FirstAddress Then
frmStationen.lstDaten.List = MyArray
Exit Sub
End If
MyArray(lstZ, 0) = Found.Offset(0, -36)
MyArray(lstZ, 1) = Found.Offset(0, -34)
MyArray(lstZ, 2) = Found.Offset(0, -33)
MyArray(lstZ, 3) = Found.Offset(0, 0) & " / " & Found.Offset(0, -23)
MyArray(lstZ, 4) = Format(Found.Offset(0, 3), "#0.000")
MyArray(lstZ, 5) = Format(Found.Offset(0, 6), "#0.000")
MyArray(lstZ, 6) = Found.Offset(0, 11)
MyArray(lstZ, 7) = Found.Offset(0, -29)
MyArray(lstZ, 8) = Found.Offset(0, -28)
MyArray(lstZ, 9) = Found.Offset(0, 7) & " / " & Found.Offset(0, 8)
If Found.Row = z Then
frmStationen.lstDaten.List = MyArray
Exit Sub
End If
lstZ = lstZ + 1
Loop While Not Found Is Nothing
Else
With frmStationen.lstDaten
MyArray(0, 0) = Cells(1, Found.Column - 36)
MyArray(0, 1) = Cells(1, Found.Column - 34)
MyArray(0, 2) = Cells(1, Found.Column - 33)
MyArray(0, 3) = Cells(1, Found.Column) & " / " & Cells(1, Found.Column - 23)
MyArray(0, 4) = Cells(1, Found.Column + 3)
MyArray(0, 5) = Cells(1, Found.Column + 6)
MyArray(0, 6) = Cells(1, Found.Column + 11)
MyArray(0, 7) = Cells(1, Found.Column - 29)
MyArray(0, 8) = Cells(1, Found.Column - 28)
MyArray(0, 9) = Cells(1, Found.Column + 7) & " / " & Cells(1, Found.Column + 8) lstZ = lstZ + 1
If cboStationsseite = Range(Found.Address).Offset(0, 7) Then
MyArray(lstZ, 0) = Found.Offset(0, -36)
MyArray(lstZ, 1) = Found.Offset(0, -34)
MyArray(lstZ, 2) = Found.Offset(0, -33)
MyArray(lstZ, 3) = Found.Offset(0, 0) & " / " & Found.Offset(0, -23)
MyArray(lstZ, 4) = Format(Found.Offset(0, 3), "#0.000")
MyArray(lstZ, 5) = Format(Found.Offset(0, 6), "#0.000")
MyArray(lstZ, 6) = Found.Offset(0, 11)
MyArray(lstZ, 7) = Found.Offset(0, -29)
MyArray(lstZ, 8) = Found.Offset(0, -28)
MyArray(lstZ, 9) = Found.Offset(0, 7) & " / " & Found.Offset(0, 8)
lstZ = lstZ + 1
End If
End With
Do
Set Found = .FindNext(Found)
If Found.Address = FirstAddress Then
frmStationen.lstDaten.List = MyArray
Exit Sub
End If
If cboStationsseite = Range(Found.Address).Offset(0, 7) Then
MyArray(lstZ, 0) = Found.Offset(0, -36)
MyArray(lstZ, 1) = Found.Offset(0, -34)
MyArray(lstZ, 2) = Found.Offset(0, -33)
MyArray(lstZ, 3) = Found.Offset(0, 0) & " / " & Found.Offset(0, -23)
MyArray(lstZ, 4) = Format(Found.Offset(0, 3), "#0.000")
MyArray(lstZ, 5) = Format(Found.Offset(0, 6), "#0.000")
MyArray(lstZ, 6) = Found.Offset(0, 11)
MyArray(lstZ, 7) = Found.Offset(0, -29)
MyArray(lstZ, 8) = Found.Offset(0, -28)
MyArray(lstZ, 9) = Found.Offset(0, 7) & " / " & Found.Offset(0, 8)
If Found.Row = z Then
frmStationen.lstDaten.List = MyArray
Exit Sub
End If
lstZ = lstZ + 1
End If
Loop While Not Found Is Nothing
On Error GoTo 0
End If
End With
frmStationen.lstDaten.List = MyArray
End Sub
Gruß Robert