AW: Auswerten/Selektieren
04.08.2014 12:03:54
fcs
Hallo Thorsten,
Ich hoffe man kann es nachvollziehen.
Ohne Beispieldaten im Tabellenblatt ist es etwas schwierig.
Ich mal versucht was draus zu machen. Bei den Spalten G/H/I/K könnte man es wohl auch anders machen bzw. ich hab es ggf. auch nicht 100% verstanden. Ich vermute, dass in den Spalte G,H und I nur angekreuzt wird.
Nachfolgend mal der Code für das Userform, wie man es machen könnte. Nicht erschrecken - das Ganze wird dadurch kompliziert, dass die Auswahllisten der Listen nicht direkt aus der Tabelle entnommen werden können, sondern mit vielen Prüfungen/Wertvergleichen per Code zusammengestellt werden müssen.
Gruß
Franz
'Code Userform "Auswertung"
Option Explicit
Private wksData As Worksheet
Private Sub Auswerten_Cmd_Click()
Dim objCol As Collection, intCol As Integer
Dim arrListe()
Dim lngZeile As Long
Dim strOrt As String, strSchulform As String
Dim strG As String, strH As String, strI As String, strStart As String
On Error GoTo Fehler
If Me.ComboBox1.ListIndex = -1 Then
MsgBox "Bitte erst Ort - Schulform auswählen"
Else
With Me.ComboBox1
strOrt = .List(.ListIndex, 0)
strSchulform = .List(.ListIndex, 1)
End With
With Me.ComboBox2
If .ListIndex > 0 Then
strG = .List(.ListIndex, 0)
strH = .List(.ListIndex, 1)
strI = .List(.ListIndex, 2)
strStart = .List(.ListIndex, 3)
Else
strG = ""
strH = ""
strI = ""
strStart = "Alle"
End If
End With
With wksData
'Liste für Listbox1 gemäß Auswahl in Comboboxen zustammenstellen
Set objCol = New Collection
For lngZeile = 2 To .Cells(.Rows.Count, 6).End(xlUp).Row
If strOrt = .Cells(lngZeile, 6).Value And strSchulform = .Cells(lngZeile, 3).Value Then
If strStart = "Alle" Then
objCol.Add lngZeile
Else
If strG = .Cells(lngZeile, 7).Text _
And strH = .Cells(lngZeile, 8).Text _
And strI = .Cells(lngZeile, 9).Text _
And strStart = Format(.Cells(lngZeile, 11), "h:mm") Then
objCol.Add lngZeile
End If
End If
End If
Next
If objCol.Count > 0 Then
ReDim arrListe(1 To objCol.Count, 1 To 8)
For intCol = 1 To objCol.Count
arrListe(intCol, 1) = .Cells(objCol(intCol), 1)
arrListe(intCol, 2) = .Cells(objCol(intCol), 2)
arrListe(intCol, 3) = .Cells(objCol(intCol), 3)
arrListe(intCol, 4) = .Cells(objCol(intCol), 6)
arrListe(intCol, 5) = .Cells(objCol(intCol), 7)
arrListe(intCol, 6) = .Cells(objCol(intCol), 8)
arrListe(intCol, 7) = .Cells(objCol(intCol), 9)
arrListe(intCol, 8) = Format(.Cells(objCol(intCol), 11), "h:mm")
Next
With Me.ListBox1
.ColumnCount = 8
.ColumnWidths = "40pt;100pt;80pt;80pt;40Pt;40Pt;40Pt;60Pt"
.List = arrListe
Erase arrListe
End With
End If
End With
Set objCol = Nothing
End If
Fehler:
With Err
Select Case .Number
Case 0 'alles OK
Case 457 'doppelter Collection-Keywert
Resume Next
Case Else
MsgBox "fehler-Nr.: " & .Number & vbLf & .Description
End Select
End With
End Sub
Private Sub ComboBox1_Change()
Dim objCol As Collection, intCol As Integer
Dim arrListe()
Dim lngZeile As Long
Dim strOrt As String, strSchulform As String
On Error GoTo Fehler
If Me.ComboBox1.ListIndex = -1 Then Exit Sub
With Me.ComboBox1
strOrt = .List(.ListIndex, 0)
strSchulform = .List(.ListIndex, 1)
End With
With wksData
'Liste für "nein, nur vormittags" "ja, auch nachmittags" "nur nachmittags" " _
Startzeitpunkt"
' zur Auswahl in Combobox1 zusammenstellen
Set objCol = New Collection
lngZeile = 1
'Spaltentitel übernehmen
objCol.Add lngZeile, Key:=.Cells(lngZeile, 7) & "|" & .Cells(lngZeile, 8) _
& "|" & .Cells(lngZeile, 9) & "|" & .Cells(lngZeile, 11)
For lngZeile = 2 To .Cells(.Rows.Count, 6).End(xlUp).Row
If strOrt = .Cells(lngZeile, 6).Value And strSchulform = .Cells(lngZeile, 3).Value Then
objCol.Add lngZeile, Key:=.Cells(lngZeile, 7) & "|" & .Cells(lngZeile, 8) _
& "|" & .Cells(lngZeile, 9) & "|" & Format(.Cells(lngZeile, 11), "hh:mm")
End If
Next
With Me.ComboBox2 'Formatieren/Einrichten
.ColumnCount = 4
.ListWidth = 300
.ControlTipText = "Bei ""Startzeitpunkt"" werden alle Schlen zu Ort/Schulform angezeigt"
.TextColumn = 4
.TextAlign = fmTextAlignCenter
.Clear
End With
If objCol.Count > 0 Then
ReDim arrListe(1 To objCol.Count, 1 To 4)
For intCol = 1 To objCol.Count
arrListe(intCol, 1) = .Cells(objCol(intCol), 7)
arrListe(intCol, 2) = .Cells(objCol(intCol), 8)
arrListe(intCol, 3) = .Cells(objCol(intCol), 9)
arrListe(intCol, 4) = Format(.Cells(objCol(intCol), 11), "h:mm")
Next
Me.ComboBox2.List = arrListe
Erase arrListe
End If
End With
Set objCol = Nothing
Fehler:
With Err
Select Case .Number
Case 0 'alles OK
Case 457 'doppelter Collection-Keywert
Resume Next
Case Else
MsgBox "fehler-Nr.: " & .Number & vbLf & .Description
End Select
End With
End Sub
Private Sub UserForm_activate()
Dim objCol As Collection, intCol As Integer
Dim arrListe()
Dim lngZeile As Long
On Error GoTo Fehler
Set wksData = Worksheets("Teilnahme")
With wksData
'Liste Ort - Schulformen zusammenstellen
Set objCol = New Collection
For lngZeile = 2 To .Cells(.Rows.Count, 6).End(xlUp).Row
objCol.Add lngZeile, Key:=.Cells(lngZeile, 6) & "|" & .Cells(lngZeile, 3)
Next
With Me.ComboBox1
.ColumnCount = 3
.ListWidth = 150
.TextColumn = 3
.Clear
End With
If objCol.Count > 0 Then
ReDim arrListe(1 To objCol.Count, 1 To 3)
For intCol = 1 To objCol.Count
arrListe(intCol, 1) = .Cells(objCol(intCol), 6)
arrListe(intCol, 2) = .Cells(objCol(intCol), 3)
arrListe(intCol, 3) = .Cells(objCol(intCol), 6) & " | " & .Cells(objCol(intCol), 3)
Next
Me.ComboBox1.List = arrListe
Erase arrListe
End If
End With
Set objCol = Nothing
Fehler:
With Err
Select Case .Number
Case 0 'alles OK
Case 457 'doppelter Collection-Keywert
Resume Next
Case Else
MsgBox "fehler-Nr.: " & .Number & vbLf & .Description
End Select
End With
End Sub
Private Sub zurück_Click()
Unload Auswertung
End Sub
Private Sub Druck_Cmd_Click()
Druck_Cmd.Visible = False
Auswerten_Cmd.Visible = False
Me.PrintForm
Auswerten_Cmd.Visible = True
Druck_Cmd.Visible = True
End Sub