Hallo Burghard,
mit den folgenden Makros kannst die Tipps in die Auswertung übertragen. Entweder ein für einzelnes Team oder für alle Teams.
Gruß
Franz
Sub TippsNachAuswertung()
'Einzelnes Team mit Input-Box-Eingabe
Dim wksTipp As Worksheet, wksAus As Worksheet
Dim ZeileTipp&, ZeileAus&, ZeileMaxTipp&, i%
Dim SpalteGerade%, SpalteUngerade%
Dim Mannschaft
Set wksTipp = ActiveWorkbook.Worksheets("Spieltage")
Set wksAus = ActiveWorkbook.Worksheets("Auswertung")
ZeileAus = 1
SpalteGerade = 11 '1. Spalte der geraden Spieltage
SpalteUngerade = 1 '1. Spalte der ungeraden Spieltage
'Letzte Zeile mit Tipps
ZeileMaxTipp = wksTipp.Cells(wksTipp.Rows.Count, SpalteUngerade).End(xlUp).Row
ZeileTipp = 1
Mannschaft = InputBox("Welche Mannschaft nach Auswertung?" & vbLf & _
"Genaue Schreibweise beachten!!!", "Team nach Auswertung", "")
If Mannschaft = "" Then Exit Sub 'Abbrechen gewählt
With wksTipp
Do Until ZeileTipp > ZeileMaxTipp
If InStr(1, .Cells(ZeileTipp, SpalteUngerade), "Spieltag") > 0 Then
For i = 1 To 9
If .Cells(ZeileTipp + i, SpalteUngerade) = Mannschaft Or _
.Cells(ZeileTipp + i, SpalteUngerade + 1) = Mannschaft Then
ZeileAus = ZeileAus + 1
wksAus.Cells(ZeileAus, 1).Value = .Cells(ZeileTipp + i, SpalteUngerade)
wksAus.Cells(ZeileAus, 2).Value = .Cells(ZeileTipp + i, SpalteUngerade + 1)
wksAus.Cells(ZeileAus, 3).Value = .Cells(ZeileTipp + i, SpalteUngerade + 2)
wksAus.Cells(ZeileAus, 4).Value = ":"
wksAus.Cells(ZeileAus, 5).Value = .Cells(ZeileTipp + i, SpalteUngerade + 4)
Exit For
End If
Next i
For i = 1 To 9
If .Cells(ZeileTipp + i, SpalteGerade) = Mannschaft Or _
.Cells(ZeileTipp + i, SpalteGerade + 1) = Mannschaft Then
ZeileAus = ZeileAus + 1
wksAus.Cells(ZeileAus, 1).Value = .Cells(ZeileTipp + i, SpalteGerade)
wksAus.Cells(ZeileAus, 2).Value = .Cells(ZeileTipp + i, SpalteGerade + 1)
wksAus.Cells(ZeileAus, 3).Value = .Cells(ZeileTipp + i, SpalteGerade + 2)
wksAus.Cells(ZeileAus, 4).Value = ":"
wksAus.Cells(ZeileAus, 5).Value = .Cells(ZeileTipp + i, SpalteGerade + 4)
Exit For
End If
Next i
ZeileTipp = ZeileTipp + 9
End If
ZeileTipp = ZeileTipp + 1
Loop
End With
'Formate kopieren
With wksAus
ZeileMaxTipp = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range("A2:E3").Copy
For ZeileAus = 4 To ZeileMaxTipp Step 2
.Cells(ZeileAus, 1).Range("A1:E2").PasteSpecial Paste:=xlFormats
Next
Application.CutCopyMode = False
End With
End Sub
Sub TippsNachAuswertung2()
'Alle Teams hintereinander weg
Dim wksTipp As Worksheet, wksAus As Worksheet
Dim ZeileTipp&, ZeileAus&, ZeileMaxTipp&, i%
Dim SpalteGerade%, SpalteUngerade%, Spalte%, Zeile&
Dim Mannschaft
Set wksTipp = ActiveWorkbook.Worksheets("Spieltage")
Set wksAus = ActiveWorkbook.Worksheets("Auswertung")
ZeileAus = 1
SpalteGerade = 11 '1. Spalte der geraden Spieltage
SpalteUngerade = 1 '1. Spalte der ungeraden Spieltage
'Letzte Zeile mit Tipps
ZeileMaxTipp = wksTipp.Cells(wksTipp.Rows.Count, SpalteUngerade).End(xlUp).Row
For Spalte = 1 To 2
For Zeile = 2 To 10
ZeileTipp = 1
With wksTipp
Mannschaft = .Cells(Zeile, Spalte).Value
Do Until ZeileTipp > ZeileMaxTipp
If InStr(1, .Cells(ZeileTipp, SpalteUngerade), "Spieltag") > 0 Then
For i = 1 To 9
If .Cells(ZeileTipp + i, SpalteUngerade) = Mannschaft Or _
.Cells(ZeileTipp + i, SpalteUngerade + 1) = Mannschaft Then
ZeileAus = ZeileAus + 1
wksAus.Cells(ZeileAus, 1).Value = .Cells(ZeileTipp + i, SpalteUngerade)
wksAus.Cells(ZeileAus, 2).Value = .Cells(ZeileTipp + i, SpalteUngerade + 1)
wksAus.Cells(ZeileAus, 3).Value = .Cells(ZeileTipp + i, SpalteUngerade + 2)
wksAus.Cells(ZeileAus, 4).Value = ":"
wksAus.Cells(ZeileAus, 5).Value = .Cells(ZeileTipp + i, SpalteUngerade + 4)
Exit For
End If
Next i
For i = 1 To 9
If .Cells(ZeileTipp + i, SpalteGerade) = Mannschaft Or _
.Cells(ZeileTipp + i, SpalteGerade + 1) = Mannschaft Then
ZeileAus = ZeileAus + 1
wksAus.Cells(ZeileAus, 1).Value = .Cells(ZeileTipp + i, SpalteGerade)
wksAus.Cells(ZeileAus, 2).Value = .Cells(ZeileTipp + i, SpalteGerade + 1)
wksAus.Cells(ZeileAus, 3).Value = .Cells(ZeileTipp + i, SpalteGerade + 2)
wksAus.Cells(ZeileAus, 4).Value = ":"
wksAus.Cells(ZeileAus, 5).Value = .Cells(ZeileTipp + i, SpalteGerade + 4)
Exit For
End If
Next i
ZeileTipp = ZeileTipp + 9
End If
ZeileTipp = ZeileTipp + 1
Loop
End With
Next
Next
'Formate kopieren
With wksAus
ZeileMaxTipp = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range("A2:E3").Copy
For ZeileAus = 4 To ZeileMaxTipp Step 2
.Cells(ZeileAus, 1).Range("A1:E2").PasteSpecial Paste:=xlFormats
Next
Application.CutCopyMode = False
End With
End Sub
