AW: Makro zur Auswertung
14.01.2007 13:06:24
fcs
Hallo Günther,
nach kleine Problemen die Sortierung der Spieler mit negativer Geasmt-Punktzahl korrekt hinzubekommen funktioniert es jetz.
Die Serie, für die der Tischausdruck erstellt werden soll wird erkannt. Dazu muß der Eingabebereich für die noch nicht gespielten Serien leer sein. Auch der Tischplan für die 1. Serie kann gedruckt werden. Die Daten werden dann ohne Sortierung so gedruckt, wie sie im Blatt "Eingabe" eingegeben sind.
Das Makro erkennt auf Grund der eingegebenen Formeln die Spalte "Gesamt", so dass beliebig viele Spalten für Serien eingefügt werden können ohne das Makro anpassen zu müssen. Zum Testen habe ich den Code so erstellt, dass für die Ausgabe Drucken oder Seitenvorschau gewählt werden kann. Wenn alles rund läuft, dann kannst du ja die Code-Abschnitte für die Seitenvorschau so anpassen/löschen, dass direkt gedruckt wird.
Gruss
Franz
Sub Tischausdruck()
Dim wksEingabe As Worksheet, wksAusdruck As Worksheet
Dim LetzteZeile As Long, ZeileEingabe As Long, Serie As Integer, Gesamt As Integer
Dim Spalte As Integer, AnzSpieler As Integer, Spieler As Integer
Dim Spieler3er(), Spieler3 As Integer, zeile3er As Long, Tische3 As Integer
Dim Seitenvorschau
'Sicherheitsabfrage
If MsgBox("Tischausdruck erstellen?", vbYesNo, "Tischausdruck") = vbNo Then Exit Sub
Seitenvorschau = MsgBox("Druckausgabe zum Testen als Seitenvorschau?", vbYesNo + vbQuestion, "Tischausdruck")
Set wksEingabe = Worksheets("Eingabe") 'Tabellenblatt mit den Eingaben
Set wksAusdruck = Worksheets("Tischausdruck") 'Tabellenblatt für Tischausdruck
ZeileEingabe = 2 '1. Zeile mit einem Spielernamen in Eingabeblatt
With wksEingabe
'Spalte mit Gesamtpunktzahl (Letzte Spalte mit Daten)
Gesamt = .Cells(ZeileEingabe, .Columns.Count).End(xlToLeft).Column
'Serie ermitteln, Datenbereich der noch nicht gespielten Serien muss leer sein! (Nur Titelzeile)
For Spalte = 5 To Gesamt - 1
If .Cells(.Rows.Count, Spalte).End(xlUp).Row = ZeileEingabe - 1 Then
Serie = Spalte - 4
Exit For
End If
Next
If Serie = 0 Then
If MsgBox("Es wurden bereits alle Serien gespielt!" & vbLf & vbLf _
& "Tischausdruck erstellen?", vbYesNo + vbQuestion, "Tischausdruck") = vbNo Then
Exit Sub
End If
End If
'Eingabedaten neu sortieren, wenn schon Ergebnisse für eine Serie eingegeben sind
If Serie > 1 Then
'Letzte Zeile mit Spielername in Spalte C
LetzteZeile = .Cells(.Rows.Count, "C").End(xlUp).Row
'Spieler nach Namen sortieren, erforderlich, damit leere Einträge der 3er-Tische ans _
Ende sortiert werden und Spieler mit negative Punktzahlen korrekt einsortiert werden
.Range(.Cells(ZeileEingabe - 1, 3), .Cells(LetzteZeile, Gesamt)).Sort _
Key1:=.Cells(ZeileEingabe - 1, 3), Order1:=xlAscending, Header:=xlYes
'Letzte Zeile mit Spielername in Spalte C
LetzteZeile = .Cells(.Rows.Count, "C").End(xlUp).Row
'Spieler nach Ergebnis sortieren
.Range(.Cells(ZeileEingabe - 1, 3), .Cells(LetzteZeile, Gesamt)).Sort _
Key1:=.Cells(ZeileEingabe - 1, Gesamt), Order1:=xlDescending, Header:=xlYes
'Aus der letzten Zelle mit Daten in Spalte C die Anzahl Spieler ermitteln
AnzSpieler = LetzteZeile - ZeileEingabe + 1
'3er Tischen die Spieler zuordnen
If AnzSpieler Mod 4 <> 0 Then
Tische3 = 4 - AnzSpieler Mod 4
zeile3er = LetzteZeile - Tische3 * 3 + 1 'Zeile des 1. Spielers an einem 3er-Tisch
'Spieler-Daten der 3er-Tische in Datenfeld einlesen
ReDim Spieler3er(1 To Tische3 * 3, 1 To Gesamt - 1)
For Spieler3 = 1 To Tische3 * 3
For Spalte = 3 To Gesamt - 1
Spieler3er(Spieler3, Spalte) = .Cells(zeile3er + Spieler3 - 1, Spalte).Value
Next
Next
'Daten der Spieler an 3er-Tischen eintragen
Spieler3 = 1
For Tische3 = 1 To 4 - AnzSpieler Mod 4
'Daten der 3 Spieler eintragen
For Spieler = 1 To 3
For Spalte = 3 To Gesamt - 1
.Cells(zeile3er, Spalte).Value = Spieler3er(Spieler3, Spalte)
Next
Spieler3 = Spieler3 + 1
zeile3er = zeile3er + 1
Next
'4. Spieler ohne Daten, Zellinhalte löschen
For Spalte = 3 To Gesamt - 1
.Cells(zeile3er, Spalte).ClearContents
Next
zeile3er = zeile3er + 1
Next
End If
End If
'Tischausdrucke erstellen
'Letzte Zeile mit Spielername in Spalte C
LetzteZeile = .Cells(.Rows.Count, "C").End(xlUp).Row
'Serie Nr. eintragen
wksAusdruck.Cells(2, "B").Value = "Setzplan für die " & Serie & ". Serie"
Do Until ZeileEingabe > LetzteZeile
'Tisch Nr. eintragen
wksAusdruck.Cells(5, "C").Value = .Cells(ZeileEingabe, "A").Value
For Spieler = 1 To 4
'Spielername eintragen
wksAusdruck.Cells(6 + Spieler, "C").Value = .Cells(ZeileEingabe, "C").Value
'Punktzahl eintragen
If .Cells(ZeileEingabe, "C").Value = "" Then '3er Tisch
wksAusdruck.Cells(6 + Spieler, "G").Value = ""
Else
wksAusdruck.Cells(6 + Spieler, "G").Value = .Cells(ZeileEingabe, Gesamt).Value
End If
ZeileEingabe = ZeileEingabe + 1
Next
If Seitenvorschau = vbNo Then
wksAusdruck.PrintOut
Else
wksAusdruck.PrintPreview 'Zeile zum Testen und Papiersparen
End If
Loop
End With
End Sub