AW: Userform anzeigen bis zweite geladen
26.07.2020 22:44:19
Mani
Warum dauert es bei mir so lange ?
Was habe ich verkehrt gemacht ?
Private Sub UserForm_Initialize()
Dim LetzteZeile As Long
Dim i As Long, j As Long
Dim objCol As Collection
Dim aLast As Integer, aNext As Integer
Dim aTmp
Dim sVersion As String
Dim lngZeile As Long
Dim lngCount As Long
Dim lngCounter As Long
Me.Caption = "Benutzer: " & Application.UserName 'Userform Name aktueller Benutzer
On Error GoTo Fehler
Set wksData = Worksheets("Geburt")
With wksData
LetzteZeile = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
With Me.ListBox1
.Clear
.ColumnCount = 26
.ColumnWidths = "2cm;2,5cm;1,5cm;1,5cm;2,5cm;1,5cm;1,5cm;2,5cm;2cm;1,2cm;2cm;2cm;0cm;0cm; _
0cm;0cm;0cm;0cm;0cm;0cm;0cm;0cm;0cm;0cm;0cm"
End With
With Me.ListBox2
.Clear
.ColumnCount = 1
.ColumnWidths = "1cm"
End With
With Me.ListBox3
.Clear
.ColumnCount = 1
.ColumnWidths = "1cm"
End With
With Me.ListBox4
.Clear
.ColumnCount = 1
.ColumnWidths = "1cm"
End With
With Me.ListBox5
.Clear
.ColumnCount = 1
.ColumnWidths = "1cm"
End With
With Me.ListBox6
.Clear
.ColumnCount = 1
.ColumnWidths = "1cm"
End With
With Me.ListBox7
.Clear
.ColumnCount = 1
.ColumnWidths = "1cm"
End With
ReDim arrValues1(8 To LetzteZeile, 1 To 26)
With wksData
For i = 8 To LetzteZeile
arrValues1(i, 1) = .Cells(i, 3).Text
arrValues1(i, 2) = .Cells(i, 2).Text
arrValues1(i, 3) = .Cells(i, 4).Text
arrValues1(i, 4) = .Cells(i, 6).Text
arrValues1(i, 5) = .Cells(i, 8).Text
arrValues1(i, 6) = .Cells(i, 11).Text
arrValues1(i, 7) = .Cells(i, 12).Text
arrValues1(i, 8) = .Cells(i, 13).Text
arrValues1(i, 9) = .Cells(i, 14).Text
arrValues1(i, 10) = .Cells(i, 16).Text
arrValues1(i, 11) = .Cells(i, 17).Text
arrValues1(i, 12) = .Cells(i, 19).Text
arrValues1(i, 13) = .Cells(i, 7).Text
arrValues1(i, 14) = .Cells(i, 18).Text
arrValues1(i, 15) = .Cells(i, 21).Text
arrValues1(i, 16) = .Cells(i, 20).Text
arrValues1(i, 17) = .Cells(i, 22).Text
arrValues1(i, 18) = .Cells(i, 28).Text
arrValues1(i, 19) = .Cells(i, 29).Text
arrValues1(i, 20) = .Cells(i, 27).Text
arrValues1(i, 21) = .Cells(i, 30).Text
arrValues1(i, 22) = .Cells(i, 31).Text
arrValues1(i, 23) = .Cells(i, 15).Text
arrValues1(i, 24) = i
arrValues1(i, 25) = "x"
arrValues1(i, 26) = .Cells(i, 39).Text
Next i
ListBox1.List = arrValues1
Set objCol = New Collection
For i = 8 To LetzteZeile
If Trim(.Cells(i, 13).Text) = "" Then
objCol.Add "", "(leer)"
Else
objCol.Add .Cells(i, 13).Text, .Cells(i, 13).Text
End If
Next i
With objCol
ReDim arrValues2(1 To .Count)
For i = 1 To .Count
arrValues2(i) = .Item(i)
Next i
End With
ListBox2.List = arrValues2
Set objCol = New Collection
For i = 8 To LetzteZeile
If Trim(.Cells(i, 14).Text) = "" Then
objCol.Add "", "(leer)"
Else
objCol.Add .Cells(i, 14).Text, .Cells(i, 14).Text
End If
Next i
With objCol
ReDim arrValues3(1 To .Count)
For i = 1 To .Count
arrValues3(i) = .Item(i)
Next i
End With
ListBox3.List = arrValues3
Set objCol = New Collection
For i = 8 To LetzteZeile
If Trim(.Cells(i, 16).Text) = "" Then
objCol.Add "", "(leer)"
Else
objCol.Add .Cells(i, 16).Text, .Cells(i, 16).Text
End If
Next i
With objCol
ReDim arrValues4(1 To .Count)
For i = 1 To .Count
arrValues4(i) = .Item(i)
Next i
End With
ListBox4.List = arrValues4
Set objCol = New Collection
For i = 8 To LetzteZeile
If Trim(.Cells(i, 17).Text) = "" Then
objCol.Add "", "(leer)"
Else
objCol.Add .Cells(i, 17).Text, .Cells(i, 17).Text
End If
Next i
With objCol
ReDim arrValues5(1 To .Count)
For i = 1 To .Count
arrValues5(i) = .Item(i)
Next i
End With
ListBox5.List = arrValues5
Set objCol = New Collection
For i = 8 To LetzteZeile
If Trim(.Cells(i, 12).Text) = "" Then
objCol.Add "", "(leer)"
Else
objCol.Add .Cells(i, 12).Text, .Cells(i, 12).Text
End If
Next i
With objCol
ReDim arrValues6(1 To .Count)
For i = 1 To .Count
arrValues6(i) = .Item(i)
Next i
End With
ListBox6.List = arrValues6
With ListBox6 'Sotiere Listbox
For aLast = 0 To .ListCount - 1
For aNext = aLast + 1 To .ListCount - 1
If .List(aLast) > .List(aNext) Then
aTmp = .List(aLast)
.List(aLast) = .List(aNext)
.List(aNext) = aTmp
End If
Next aNext
Next aLast
End With
Set objCol = New Collection
For i = 8 To LetzteZeile
If Trim(.Cells(i, 11).Text) = "" Then
objCol.Add "", "(leer)"
Else
objCol.Add .Cells(i, 11).Value, .Cells(i, 11).Text
End If
Next i
With objCol
ReDim arrValues7(1 To .Count)
For i = 1 To .Count
arrValues7(i) = .Item(i)
Next i
End With
ListBox7.List = arrValues7
End With
With ListBox7 'Sotiere Listbox
For aLast = 0 To .ListCount - 1
For aNext = aLast + 1 To .ListCount - 1
If .List(aLast) > .List(aNext) Then
aTmp = .List(aLast)
.List(aLast) = .List(aNext)
.List(aNext) = aTmp
End If
Next aNext
Next aLast
End With
Fehler:
With Err
Select Case .Number
Case 0 ' alles OK
Case 457 'Doppelter Key in selection
Resume Next
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End Select
End With
'Übertrage Select in Listbox
lngCount = Me.ListBox1.ListCount
For lngCounter = 1 To lngCount
If Me.ListBox1.Column(22, lngCounter - 1) = 1 Then
Me.ListBox1.Selected(lngCounter - 1) = True
End If
Next lngCounter
End Sub