Live-Forum - Die aktuellen Beiträge
Datum
Titel
25.04.2024 17:49:39
Bedingte Formatierung
25.04.2024 16:50:59
2 Zellen in 2 Blättern mit unterschiedlichen Bereichen vergl
25.04.2024 15:03:35
Unterschiedliche Dateien miteinander abgleichen lassen
25.04.2024 14:05:48
Makro in aktueller Zelle ausführen mit Doppelklick
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1044to1048
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1044to1048
1044to1048
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

TINO ---> Help!

TINO ---> Help!
Markus
Hallo Tino,
auf diesen Beitrag hat sich leider keiner gemeldet. Vermutlich zu unverschämt oder viel zu aufwendig.
https://www.herber.de/forum/messages/1046431.html
Ich habe mal in einem Beitrag von Dir gelesen, dass Du VBA einerseits aus Spass machst, anderseits aber auch um paar "Groschen" nebebei zu verdienen.
Würde mir das gerne - wenn es sich im Rahmen hält - etwas kosten lassen. Wärst Du interessant? Wenn ja, hast Du eine grobe Richtung?
Kannst Dich ja mal melden. Vielen Dank und schönen Abend!
Markus
AW: TINO ---> Help!
Reinhard
Hi Markus,
Tino steht in der Profilliste (oben rechts Forums-seiten---Profile...)
Dadurch könntest du ihn anmailen...
Gruß
Reinhard
AW: TINO ---> Help!
Hajo_Zi
Hallo Reinhard,
auch wenn im Profil die Mailadresse steht sollte man eine Mail nur mit Rückfrage schreiben.

AW: TINO ---> Help!
Reinhard
Hallo Hajo,
du hast vollkommen Recht.
Naja zu 99,98% :-)
Ich dachte ich mach was für Tino wenn ich den vielleicht unbekannten Tipp mit den Profilen gebe.
Mich darf jeder ungefragt anmailen der mir einen Exceljob anbietet *gg*
Gruß
Reinhard
Anzeige
@Reinhard, danke ist nett von Dir oT.
Dir
AW: TINO ---> Help!
Tino
Hallo,
habe den Beitrag erst jetzt gesehen.
Danke erst mal für das entgegengebrachte Vertrauen.
Also wie Du schon richtig gelesen hast, mach ich dies um ein bar Groschen zu verdienen,
aber nur im kleinen Rahmen (kleine Projekte), muss mich auch an die Regeln für Nebentätigkeiten halten (wegen Finanzamt).
Ich erstelle VBA Lösungen für Excel und kleine VB6 Tools.
Schau mal hier, da findest Du eigentlich alles.

www.VBA-Excel.de


Zu Deinem Beitrag, ich bin kein Fußballfan,
kannst Du mir sagen wie in Deiner Tabelle zu erkennen ist,
wann der erste Spieltag, wann der zweite Spieltag usw. ist?
Vielleicht können wir es auch im Forum lösen.
Gruß Tino
Anzeige
hier mal ein Code
Tino
Hallo,
hier mal ein erster Code, wie gesagt ich habe von Fußball keine Ahnung.
Ob das jetzt die einzelnen Spieltage sind, davon habe ich keinen blassen Schimmer. 
Sub EgebnisTabelle()
Dim Bereich As Range, tBereich As Range
Dim meAr, LCol
Dim i As Integer
Dim NeuTab As Worksheet

Set Bereich = Sheets("Gesamt").Range("A3:A20")
Redim meAr(Bereich.Cells.Count - 1, 5)

With Application
 .ScreenUpdating = False
 .EnableEvents = False

    For Each Bereich In Bereich
     
      Set tBereich = Sheets("Gesamt").Range(Bereich.Offset(0, 2), Bereich.Offset(0, 55))

      LCol = .Match(0, tBereich, -1)
        
        If IsNumeric(LCol) Then
          With .WorksheetFunction
                meAr(i, 0) = Bereich
                meAr(i, 1) = "gegen"
                meAr(i, 2) = .Index(tBereich.Offset(-(tBereich.Row - 2), 0), 1, .Match(-1, tBereich, -1) - 2)
                meAr(i, 3) = .Index(tBereich, 1, .Match(-1, tBereich, -1) - 2)
                meAr(i, 4) = ":"
                meAr(i, 5) = .Index(tBereich, 1, .Match(-1, tBereich, -1))
                i = i + 1
          End With
        End If
    
    Next Bereich


    Set NeuTab = Sheets.Add(, ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    With NeuTab
        NeuTab.Range("B2").Resize(Ubound(meAr, 1) + 1, Ubound(meAr, 2) + 1) = meAr
        Set Bereich = .Range("A2", .Cells(.Rows.Count, 2).End(xlUp).Offset(0, -1))
        Bereich.FormulaR1C1 = "=ROW(R[-1]C1)& "".Spieltag"""
        Bereich.Value = Bereich.Value
        NeuTab.Columns("A:G").EntireColumn.AutoFit
    End With
 .ScreenUpdating = True
 .EnableEvents = True
End With
End Sub


Gruß Tino

Anzeige
Korrektur!, eine 0 muss noch -1 sein.
Tino
Hallo,
eine Null habe ich vergessen auf -1 zu stellen.
Sub EgebnisTabelle()
Dim Bereich As Range, tBereich As Range
Dim meAr, LCol
Dim i As Integer
Dim NeuTab As Worksheet

Set Bereich = Sheets("Gesamt").Range("A3:A20")
Redim meAr(Bereich.Cells.Count - 1, 5)

With Application
 .ScreenUpdating = False
 .EnableEvents = False

    For Each Bereich In Bereich
     
      Set tBereich = Sheets("Gesamt").Range(Bereich.Offset(0, 2), Bereich.Offset(0, 55))

      LCol = .Match(-1, tBereich, -1)
        
        If IsNumeric(LCol) Then
          With .WorksheetFunction
                meAr(i, 0) = Bereich
                meAr(i, 1) = "gegen"
                meAr(i, 2) = .Index(tBereich.Offset(-(tBereich.Row - 2), 0), 1, LCol - 2)
                meAr(i, 3) = .Index(tBereich, 1, LCol - 2)
                meAr(i, 4) = ":"
                meAr(i, 5) = .Index(tBereich, 1, LCol)
                i = i + 1
          End With
        End If
    
    Next Bereich


    Set NeuTab = Sheets.Add(, ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    With NeuTab
        NeuTab.Range("B2").Resize(Ubound(meAr, 1) + 1, Ubound(meAr, 2) + 1) = meAr
        Set Bereich = .Range("A2", .Cells(.Rows.Count, 2).End(xlUp).Offset(0, -1))
        Bereich.FormulaR1C1 = "=ROW(R[-1]C1)& "".Spieltag"""
        Bereich.Value = Bereich.Value
        NeuTab.Columns("A:G").EntireColumn.AutoFit
    End With
 .ScreenUpdating = True
 .EnableEvents = True
End With
End Sub


Gruß Tino

Anzeige
geht auch ohne Index Funktion.
Tino
Hallo,
Sub EgebnisTabelle()
Dim Bereich As Range, tBereich As Range
Dim meAr, LCol
Dim i As Integer
Dim NeuTab As Worksheet

With Application
 .ScreenUpdating = False
 .EnableEvents = False
End With

 With Sheets("Gesamt")
    Set Bereich = .Range("A3:A20")
    Redim meAr(Bereich.Cells.Count - 1, 5)
 
    For Each Bereich In Bereich
     
      Set tBereich = .Range(Bereich.Offset(0, 2), Bereich.Offset(0, 55))

      LCol = Application.Match(-1, tBereich, -1)
        
        If IsNumeric(LCol) Then
                meAr(i, 0) = Bereich
                meAr(i, 1) = "gegen"
                meAr(i, 2) = .Cells(2, LCol)
                meAr(i, 3) = .Cells(tBereich.Row, LCol)
                meAr(i, 4) = ":"
                meAr(i, 5) = .Cells(tBereich.Row, LCol + 2)
                i = i + 1
        End If
    
    Next Bereich

 End With

    Set NeuTab = Sheets.Add(, ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    With NeuTab
        NeuTab.Range("B2").Resize(Ubound(meAr, 1) + 1, Ubound(meAr, 2) + 1) = meAr
        Set Bereich = .Range("A2", .Cells(.Rows.Count, 2).End(xlUp).Offset(0, -1))
        Bereich.FormulaR1C1 = "=ROW(R[-1]C1)& "".Spieltag"""
        Bereich.Value = Bereich.Value
        NeuTab.Columns("A:G").EntireColumn.AutoFit
    End With

With Application
 .ScreenUpdating = True
 .EnableEvents = True
End With

End Sub


Gruß Tino

Anzeige
Nicht ganz
Markus
Hallo Tino,
erst einmal danke, dass Du Dir das überhaupt angetan hast. Das finde ich schon echt klasse.
Du hast Fußball nicht ganz verstanden. :-) Spaß beseite.
Pro Spieltag gibt es bei 18 Mannschaften 9 Partien. Die Ergebnisse des ersten Spieltages habe ich eingetragen. Das heißt alle 9 Ergebnisse betreffen nur den ersten Spieltag. Dementsprechend müsste in dem neuen Reiter alle Spiele unter Spieltag 1 laufen. Ich mache mir als Hilfe, dass ich auch keine Mannschaft vergessen habe, die Formel in A2 (OK 1). D.h. alle Paarungen des ersten Spieltages habe ich auch mit Ergebnissen gefüllt und fehlerhafte Doppeleintragen z.B. in der Zeile vertan können nicht passieren (andernfalls würde da prüfen stehen).
Bei den nächsten Spieltagen geht das gleiche wieder von neuen los. 18 Mannschaften = 9 Spiele.
Jetzt müsste das Makro wissen, welche Ergebnissen bereits aus Spieltag 1 vorliegen, damit die neuen Ergebnisse dem zweiten Spieltag zusortiert werden können. Anschließend dann der 3,4,5 bis zum 34. Spieltag.
Prinzip soweit verstanden? Frage wäre, ist so ein Gehirn (was liegt bereits an Spieltagen und Paarungen vor) programmierbar?
Viele Grüße
Markus
Anzeige
AW: Nicht ganz
Tino
Hallo,
ok, also ich denke so langsam kann ich folgen.
Also Deine Beispiel Tabelle enthält einen Spieltag.
Kommt jetzt der zweite Spieltag,
woran erkenne ich dies in Deiner Tabelle, wird in A2 aus ok1 danach ok2?
Sollte dies nicht so sein, sollte irgendwo etwas eingebaut werden woran man dies erkennt.
Diese sollen wahrscheinlich dann in einer,
sagen wir mal Übersichtstabelle zusammengefasst werden.
Kaum zu klauben, ich mache eine Fußballtabelle.
Dieses Spiel wird mit einem runden Ball gespielt, stimmt doch oder? ;-)
PS: ich gehe jetzt erst mal ins Bett, war auf der Nachtschicht, schaue später nochmal vorbei.
Gruß Tino
Anzeige
AW: Nicht ganz
Markus
Hallo Tino,
Du hast Fussball verstanden. :-)
Aus OK1 würde bei Spieltag 2 (wenn korrekt eingegeben) OK2 werden, usw. usw. (das erfolgt mittels Formel)
Optimal wäre, wenn alle Spieltage in einem Reiter zusammengefasst werden würden.
Viele Grüße
Markus
und jetzt?
Tino
Hallo,
ok. versuche es mal hiermit,
Du musst ein leeres Tabellenblatt mit dem Namen Übersicht zuvor erstellen.
Sub EgebnisTabelle()
Dim Bereich As Range, tBereich As Range
Dim meAr, LCol
Dim i As Integer
Dim NeuTab As Worksheet

If InStr(Sheets("Gesamt").Range("A2").Text, "ok") = 0 Then Exit Sub
With Application
 .ScreenUpdating = False
 .EnableEvents = False
End With

 With Sheets("Gesamt")
    Set Bereich = .Range("A3:A20")
    Redim meAr(Bereich.Cells.Count - 1, 6)
 
    For Each Bereich In Bereich
     
      Set tBereich = .Range(Bereich.Offset(0, 2), Bereich.Offset(0, 55))

      LCol = Application.Match(-1, tBereich, -1)
        
        If IsNumeric(LCol) Then
                meAr(i, 0) = Trim$(Replace(Range("A2").Text, "ok", "")) & ". Spieltag"
                meAr(i, 1) = Bereich
                meAr(i, 2) = "gegen"
                meAr(i, 3) = .Cells(2, LCol)
                meAr(i, 4) = .Cells(tBereich.Row, LCol)
                meAr(i, 5) = ":"
                meAr(i, 6) = .Cells(tBereich.Row, LCol + 2)
                i = i + 1
        End If
    
    Next Bereich

 End With

    Set NeuTab = Sheets("Übersicht")
    LCol = Trim$(Replace(meAr(0, 0), ". Spieltag", ""))
    LCol = (LCol - 1) * 9
    LCol = IIf(LCol = 0, 1, LCol)
    LCol = IIf(LCol > 9, LCol - 1, LCol)
    With NeuTab
        .Cells(2, LCol).Resize(Ubound(meAr, 1) + 1, Ubound(meAr, 2) + 1) = meAr
        .Cells(2, LCol).EntireColumn.Font.Bold = True
        .Cells(2, LCol).EntireColumn.Font.ColorIndex = 23
        .Range(.Cells(2, LCol), .Cells(2, LCol + 7)).EntireColumn.AutoFit
    End With

With Application
 .ScreenUpdating = True
 .EnableEvents = True
End With

End Sub


Gruß Tino

Anzeige
wir müssen es anders machen....
Tino
Hallo,
wir müssen dies anders machen, weil Du ja 34 Spieltage schreibst, dann reichen die Spalten nicht aus.
Also müssen wir dies untereinander schreiben, dafür habe ich auch eine Lösung.
Sub EgebnisTabelle()
Dim Bereich As Range, tBereich As Range
Dim meAr, LRow
Dim i As Integer
Dim NeuTab As Worksheet

If InStr(Sheets("Gesamt").Range("A2").Text, "ok") = 0 Then Exit Sub
With Application
 .ScreenUpdating = False
 .EnableEvents = False
End With

 With Sheets("Gesamt")
    Set Bereich = .Range("A3:A20")
    Redim meAr(8, 6) '8= 9 Patien 
 
    For Each Bereich In Bereich
     
      Set tBereich = .Range(Bereich.Offset(0, 2), Bereich.Offset(0, 55))

      LCol = Application.Match(-1, tBereich, -1)
        
        If IsNumeric(LCol) Then
                meAr(i, 0) = Trim$(Replace(Range("A2").Text, "ok", "")) & ". Spieltag"
                meAr(i, 1) = Bereich
                meAr(i, 2) = "gegen"
                meAr(i, 3) = .Cells(2, LCol)
                meAr(i, 4) = .Cells(tBereich.Row, LCol)
                meAr(i, 5) = ":"
                meAr(i, 6) = .Cells(tBereich.Row, LCol + 2)
                i = i + 1
        End If
    
    Next Bereich

 End With

    Set NeuTab = Sheets("Übersicht")

    With NeuTab
        LRow = Application.Match(meAr(0, 0), .Columns(1), 0)
        If Not IsNumeric(LRow) Then
         LRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 2
         LRow = IIf(LRow = 3, 2, LRow)
        End If
        
        .Cells(LRow, 1).Resize(Ubound(meAr, 1) + 1, Ubound(meAr, 2) + 1) = meAr
        .Cells(LRow, 1).EntireColumn.Font.Bold = True
        .Cells(LRow, 1).EntireColumn.Font.ColorIndex = 23
        .Range(.Cells(LRow, 1), .Cells(LRow, 7)).EntireColumn.AutoFit
        
        'Sortieren 
        .Range("A2:G" & .Rows.Count).Sort .Range("A2"), xlAscending
        'Zwischenzeile einfügen 
        For LRow = .Cells(Rows.Count, 1).End(xlUp).Row - 1 To 2 Step -1
         If .Cells(LRow, 1) <> .Cells(LRow + 1, 1) Then
          .Cells(LRow + 1, 1).EntireRow.Insert
         End If
        Next LRow
        
    End With

With Application
 .ScreenUpdating = True
 .EnableEvents = True
End With

End Sub


Gruß Tino

Anzeige
bekomme einen Fehler
Markus
Hallo Tino,
der erste Spieltag lässt sich erzeugen (allerdings steht in Spalte der Übersicht dann nur = . Spieltag), die Zahl fehlt also.
Der zweite Spieltag lässt sich nicht mehr erstellen. Ich bekomme den Laufzeitfehler 9 und das Makro bleibt an folgender Stelle stehen ==== meAr(i, 0) = Trim$(Replace(Range("A2").Text, "ok", "")) & ". Spieltag"
Ich habe mal die Datei hochgeladen, damit Du das sehen kannst.
https://www.herber.de/bbs/user/59134.xls
Meine eigenen Makros habe ich löschen müssen, da ich andernfalls die Datei nicht hätte hochladen können.
Viele Grüße
Markus
Deine Angaben waren auch etwas anders.
Tino
Hallo,
ist ja auch klar, Du hattest geschrieben
Pro Spieltag gibt es bei 18 Mannschaften 9 Partien.
Nun sind in Deiner Tabelle auf einmal über 16 Partien, wie kann dass nun sein?
Mansche spielen auch gleich zweimal? (dafür muss ich mir noch was einfallen lassen)
Sub Spieltagübersicht()
Dim Bereich As Range, tBereich As Range
Dim meAr(), LRow
Dim i As Integer
Dim NeuTab As Worksheet

If InStr(Sheets("Gesamt").Range("A2").Text, "ok") = 0 Then Exit Sub
With Application
 .ScreenUpdating = False
 .EnableEvents = False
End With

 With Sheets("Gesamt")
    Set Bereich = .Range("A3:A20")
    Redim meAr(Bereich.Cells.Count - 1, 6) '8= 9 Patien 
 
    For Each Bereich In Bereich
     
      Set tBereich = .Range(Bereich.Offset(0, 2), Bereich.Offset(0, 55))

      LCol = Application.Match(-1, tBereich, -1)
        
        If IsNumeric(LCol) Then
                meAr(i, 0) = Trim$(Replace(Range("A2").Text, "ok", "")) & ". Spieltag"
                meAr(i, 1) = Bereich
                meAr(i, 2) = "gegen"
                meAr(i, 3) = .Cells(2, LCol)
                meAr(i, 4) = .Cells(tBereich.Row, LCol)
                meAr(i, 5) = ":"
                meAr(i, 6) = .Cells(tBereich.Row, LCol + 2)
                i = i + 1
        End If
    
    Next Bereich

 End With

    Set NeuTab = Sheets("Übersicht")

    With NeuTab
        
        LRow = .UsedRange(.UsedRange.Cells.Count).Row
        Set Bereich = .Range("A2", .Cells(LRow, 1)).Offset(0, .Columns.Count - 1)
        
        Bereich.FormulaR1C1 = "=IF(RC1=""2. Spieltag"",0,1)"
        On Error Resume Next
         Bereich.SpecialCells(xlCellTypeFormulas, 1).EntireRow.Delete
         .Columns(.Columns.Count).Delete
        On Error GoTo 0
        
        LRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
        .Cells(LRow, 1).Resize(Ubound(meAr, 1) + 1, Ubound(meAr, 2) + 1) = meAr
        .Cells(LRow, 1).EntireColumn.Font.Bold = True
        .Cells(LRow, 1).EntireColumn.Font.ColorIndex = 23
        .Range(.Cells(LRow, 1), .Cells(LRow, 7)).EntireColumn.AutoFit
               
        'Sortieren 
        .Range("A2:G" & .Rows.Count).Sort .Range("A2"), xlAscending
        'Zwischenzeile einfügen 
        For LRow = .Cells(Rows.Count, 1).End(xlUp).Row - 1 To 2 Step -1
         If .Cells(LRow, 1) <> .Cells(LRow + 1, 1) Then
          .Cells(LRow + 1, 1).EntireRow.Insert
         End If
        Next LRow
        
    End With

With Application
 .ScreenUpdating = True
 .EnableEvents = True
End With

End Sub


Gruß Tino

Stopp
Markus
Hallo Tiino,
ne 9 Partien pro Spieltag. In der hochgeladen Tabelle habe ich nun 2 Spieltage mit insgesamt
18 Partien (2 x 9). Schau mal in die Spalte BJ. Alle Mannschaften haben 2 Spiele.
Auch in der Überkreuztabelle sind 18 Spiele. Wie kommst Du auf 16? Bin ganz ratlos.
Hatte wie geschrieben nach 1 OK (9 Spiele am 1.Spieltag) das Makro laufen lassen und dann habe ich wieder 9 Ergebnisse eingetragen, bis 2 OK steht und das Makro laufen lassen.
Anmerkung:
Markus
Mit Deiner Änderung läuft es, allerdings nicht so wie gehofft. Denn alle 18 Spiele werden nun unter Spieltag 2 angezeigt, obwohl 9 Spiele ja zum ersten Spieltag gehören.
Aber vielleicht liegt hier auch das Mißverständnis begraben. Mein Ziel (Hoffnung) war, dass ich die Ergebnisse immer in dieser Überekuztabelle eintrage, nach ok des jeweiligen Spieltages die übersicht weiter gefüllt wird.
Hier am einfachen Beispiel am 1.FC Köln:
Am 1.Spieltag spielt Köln zu Hause gegen HSV 3:1 (das trage ich am Spieltag 1 ein, für die verbleibenden Vereine mache ich das gleiche und dann starte ich Dein Makro).
Am 2.Spieltag spielt Köln in München 0:2 (das trage ich am Spieltag 2 ein, für die verbleibenden Vereine mache ich das gleiche und dann starte ich Dein Makro).
Am 3.Spieltag spielt Köln im Bremen 1:1 (das trage ich am Spieltag 3 ein, für die verbleibenden Vereine mache ich das gleiche und dann starte ich Dein Makro).
Nun müsste in der Übersicht 3 Spieltage stehen mit insgesamt 29 Spielen (3 x 9). Für den 1.FC Köln müsste dann stehen.
1.Spieltag Köln - HSV 3:1
......
2.Spieltag München - Köln 2:0
......
3.Spieltag HSV - Köln 1:1
....
Würde ich am dritten Spieltag das Makro laufen lassen, dann müsste nur HSV gegen Köln und die Partien der anderen Mannschaften eingetragen werden. Denn der Spieltag 1 und Spieltag 2 steht ja schon da.
So einte ich das mit Gedächtnis.
So besser? Oder halt die Möglichkeit mit einer Userform die Ergebnisse einzutragen, sie in einer Übersicht einzustellen, parallel in der Überkreuztabelle. Wäre das einfacher?
AW: Anmerkung:
Markus
Korrektur - so muss es natürlich heissen
3.Spieltag Bremen- Köln 1:1
....
Würde ich am dritten Spieltag das Makro laufen lassen, dann müsste nur Bremen gegen Köln und die Partien der anderen Mannschaften eingetragen werden. Denn der Spieltag 1 und Spieltag 2 steht ja schon da. So einte ich das mit Gedächtnis.
ok. teste mal.
Tino
Hallo,
versuche es mal hiermit, muss jetzt auf die nachtschicht und kann nicht weiter testet.
Sub EgebnisTabelle()
Dim Bereich As Range, tBereich As Range
Dim meAr, LRow
Dim i As Integer
Dim NeuTab As Worksheet
Dim sFormel As String
Dim A As Long, tempCol As Long

If InStr(Sheets("Gesamt").Range("A2").Text, "ok") = 0 Then Exit Sub
With Application
 .ScreenUpdating = False
 .EnableEvents = False
End With

 With Sheets("Gesamt")
    Set Bereich = .Range("A3:A20")
    Redim meAr(288, 6) '8= 9 Patien 
 
    For Each Bereich In Bereich
     
      
    
       For A = 1 To 18
         Set tBereich = .Range(Bereich.Offset(0, 2 + tempCol), Bereich.Offset(0, 55))
           
           Lcol = Application.Match(-1, tBereich, -1)
           If IsNumeric(Lcol) Then
            tempCol = tempCol + Lcol
                Sheets("Übersicht").Range("B1").FormulaR1C1 = _
                "=SUMPRODUCT((R[1]C:R[999]C=""" & Bereich & """)*(R[1]C[2]:R[999]C[2]=""" & .Cells(2, Lcol) & """))"
              If Sheets("Übersicht").Range("B1") = 0 Then
                    meAr(i, 0) = Trim$(Replace(.Range("A2").Text, "ok", "")) & ". Spieltag"
                    meAr(i, 1) = Bereich
                    meAr(i, 2) = "gegen"
                    meAr(i, 3) = .Cells(2, tempCol)
                    meAr(i, 4) = .Cells(tBereich.Row, tempCol)
                    meAr(i, 5) = ":"
                    meAr(i, 6) = .Cells(tBereich.Row, tempCol + 2)
                    i = i + 1
                    tempCol = tempCol + 1
                    If tempCol > 53 Then Exit For
               End If
               Sheets("Übersicht").Range("B1").Value = ""
             Else
                Exit For
            End If
                    
        Next A
     tempCol = 0
    Next Bereich

 End With

    Set NeuTab = Sheets("Übersicht")

    With NeuTab
        LRow = Application.Match(meAr(0, 0), .Columns(1), 0)
        If Not IsNumeric(LRow) Then
         LRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 2
         LRow = IIf(LRow = 3, 2, LRow)
        End If
        
        .Cells(LRow, 1).Resize(Ubound(meAr, 1) + 1, Ubound(meAr, 2) + 1) = meAr
        .Cells(LRow, 1).EntireColumn.Font.Bold = True
        .Cells(LRow, 1).EntireColumn.Font.ColorIndex = 23
        .Range(.Cells(LRow, 1), .Cells(LRow, 7)).EntireColumn.AutoFit
        
        'Sortieren 
        .Range("A2:G" & .Rows.Count).Sort .Range("A2"), xlAscending
        'Zwischenzeile einfügen 
        For LRow = .Cells(Rows.Count, 1).End(xlUp).Row - 1 To 2 Step -1
         If .Cells(LRow, 1) <> .Cells(LRow + 1, 1) Then
          .Cells(LRow + 1, 1).EntireRow.Insert
         End If
        Next LRow
        
    End With

With Application
 .ScreenUpdating = True
 .EnableEvents = True
End With

End Sub


Bis morgen
Gruß Tino

Testergebnis
Markus
Hallo Tino,
hier mein Testergebenis:
1.Spieltag - Paarungen ok
2.Spieltag - Paarungen ok, allerdings eine Zeile (die vorletzte) zu viel. Die Heimmannschaft steht da, die Auswärtsmannschaft und das Ergebnis fehlen.
3.Spieltag - 4 Paarungen ok, dann gibt es Chaos. 5 Paarung sieht wie die fehlerhafte von Spieltag 2 (hier steht auch die gleiche Heimmannschaft) aus. Die anderen Paarungen fehlen.
Habe dann aufgehört, weil ich denke, dass die nachfolgenden Spieltage auch nicht mehr richtig laufen werden, weil Spieltag 3 unvollständig ist.
Sage schon mal ein großes Dankeschön. Im übrigen: Ich habe keine Ahnung, was der Code zu bedeuten hat. Das sieht nach bömischen Dörfern aus. :-)
Viele Grüße
Markus
vielleicht geht es so...
Tino
Hallo,
habe es jetzt mal bis zum 4. Spieltag getestet, so funktioniert es.
Teste ob es so geht.
Option Explicit

Sub EgebnisTabelle()
Dim Bereich As Range, tBereich As Range
Dim meAr, LRow, LCol
Dim i As Integer
Dim NeuTab As Worksheet
Dim sFormel As String
Dim A As Long, tempCol As Long
Dim sSpieltag As String

If InStr(Sheets("Gesamt").Range("A2").Text, "ok") = 0 Then Exit Sub
sSpieltag = Trim$(Replace(Sheets("Gesamt").Range("A2").Text, "ok", "")) & ". Spieltag"

If IsNumeric(Application.Match(sSpieltag, Sheets("Übersicht").Columns(1), 0)) Then
 MsgBox "Speiltag ist schon in der Übersicht vorhanden!", vbInformation
 Exit Sub
End If

With Application
 .ScreenUpdating = False
 .EnableEvents = False
End With

 With Sheets("Gesamt")
    Set Bereich = .Range("A3:A20")
    Redim meAr(305, 6)
 
    For Each Bereich In Bereich
     
      
    
       For A = 1 To 18
         Set tBereich = .Range(Bereich.Offset(0, 2 + tempCol), Bereich.Offset(0, 55))
           LCol = Application.Match(-1, tBereich, -1)
           If IsNumeric(LCol) Then
            tempCol = tempCol + LCol
                Sheets("Übersicht").Range("B1").FormulaR1C1 = _
                "=SUMPRODUCT((R[1]C:R[500]C=""" & Bereich & """)*(R[1]C[2]:R[500]C[2]=""" & .Cells(2, LCol) & """))"
              If Sheets("Übersicht").Range("B1") = 0 Then
                    meAr(i, 0) = sSpieltag
                    meAr(i, 1) = Bereich
                    meAr(i, 2) = "gegen"
                    meAr(i, 3) = .Cells(2, tempCol)
                    meAr(i, 4) = .Cells(tBereich.Row, tempCol)
                    meAr(i, 5) = ":"
                    meAr(i, 6) = .Cells(tBereich.Row, tempCol + 2)
                    i = i + 1
                    tempCol = tempCol + 1
                    If tempCol > 53 Then Exit For
               End If
                Sheets("Übersicht").Range("B1").Value = ""
                If tempCol > 53 Then Exit For
             Else
                Exit For
            End If
                    
        Next A
     tempCol = 0
    Next Bereich

 End With
Sheets("Übersicht").Range("B1").Value = ""
    Set NeuTab = Sheets("Übersicht")

    With NeuTab
        LRow = Application.Match(meAr(0, 0), .Columns(1), 0)
        If Not IsNumeric(LRow) Then
         LRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 2
         LRow = IIf(LRow = 3, 2, LRow)
        End If
        
        .Cells(LRow, 1).Resize(Ubound(meAr, 1) + 1, Ubound(meAr, 2) + 1) = meAr
        .Cells(LRow, 1).EntireColumn.Font.Bold = True
        .Cells(LRow, 1).EntireColumn.Font.ColorIndex = 23
        .Range(.Cells(LRow, 1), .Cells(LRow, 7)).EntireColumn.AutoFit
        
        'Sortieren 
        .Range("A2:G" & .Rows.Count).Sort .Range("A2"), xlAscending
        'Zwischenzeile einfügen 
        For LRow = .Cells(Rows.Count, 1).End(xlUp).Row - 1 To 2 Step -1
         If .Cells(LRow, 1) <> .Cells(LRow + 1, 1) Then
          .Cells(LRow + 1, 1).EntireRow.Insert
         End If
        Next LRow
        
    End With

With Application
 .ScreenUpdating = True
 .EnableEvents = True
End With
MsgBox "Daten wurden in die Übersicht aufgenommen!", vbInformation
End Sub


Gruß Tino

Rückmeldung heute Abend
Markus
Hallo Tino,
danke schön. Rückmeldung gebe ich Dir heute Abend. Bin schon richtig gespannt. Wäre super, wenn das klappen würde.
Viele Grüße
Markus
Testergebnis II
Markus
Hallo Tino,
habe getestet, komme aber auf ein anderes Ergebnis:
Spieltag 1 vollkommen ok
Spieltag 2 vollkommen ok
Spieltag 3 nur 4 Spiele vorhanden (die sind aber korrekt) - der Rest fehlt
Spieltag 4 nur 3 Spiele vorhanden (die sind aber korrekt) - der Rest fehlt
Kann aber doch nichts mit dem speichern zu tun haben, oder?
Viele Grüße
Markus
AW: Testergebnis II
Markus
Der folgende Code im Tabellenblatt "Gesamt" -> in der Überkreuztabelle kann aber keine Probleme bereiten?

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
ActiveSheet.Unprotect
Cells.Interior.ColorIndex = xlNone
With ActiveCell
Rows(.Row).Interior.ColorIndex = 6
Columns(.Column).Interior.ColorIndex = 6
End With
ActiveSheet.Protect DrawingObjects:=True, contents:=True, Scenarios:=True
End Sub


AW: Testergebnis II
Tino
Hallo,
eigentlich nicht,
weil ich nichts auswähle sondern nur lese und ich habe die Events abgestellt während der Laufzeit.
Warum?
Gruß Tino
AW: Testergebnis II
Tino
Hallo,
also der Code macht folgendes.
Er schaut in Tabelle Übersicht, ob diese Spielpaarung schon vorhanden ist,
ist diese nicht vorhanden wird diese hinzugefügt,
eben unter den entsprechenden Spieltag der in A2 steht.
Laut Deiner Tabelle kann eine Mannschaft nicht zweimal gegen die gleiche Mannschaft spielen,
also kann diese auch nur einmal vorkommen.
Natürlich ist die Reihenfolge einzuhalten, also Spieltag 3 muss vor Spieltag 4 hinzugefügt werden.
Gruß Tino
AW: Testergebnis II
Markus
Hey Tino,
also ich bin jetzt bis Spieltag 12 mit dem Ergebnis:
Spieltag 1 alle
Spieltag 2 alle
Spieltag 3 vier
Spieltag 4 drei
Spieltag 5 drei
Spieltag 6 zwei
Spieltag 7 eine
Spieltag 8 zwei
Spieltag 9 eine
Spieltag 10 zwei
Spieltag 11 eine
Spieltag 12 zwei Paarungen
Und ich rufe Dein Makro nach jedem Spieltag auf. Also die Reihenfolge 3 vor 4 oder ähnliches halte ich ein.
Komisch, dass es bei Spieltag 2 noch richtig läuft.
Aber müsste nicht irgendwann mal die fehlenden Paarungen auftauchen, wenn ich Dich da richtig verstehe
schaust Du doch nach, gibt es die Paarung schon in Deiner Übersicht, wenn nein, hinzufügen). Daher würde ich jetzt erwarten, dass bei letzten Spieltag (in diesem Fall 12) alle fehlenden Paarungen eingestellt werden.
AW: Testergebnis II
Tino
Hallo,
lade mal eine Beispielmappe hoch wo der 4. Spieltag hinzugefügt werden soll,
also in der Tabelle Gesamt sollte ok 4 stehen.
Dann schaue ich mal wo der Hund begraben ist.
Gruß Tino
AW: Testergebnis II
Markus
Hallo Tino,
habe die Datei hochgeladen. Bin bei Spieltag 12 angekommen:
https://www.herber.de/bbs/user/59185.xls
Musste meine Makros und einige Reiter (Spieltage) entfernen. Das sollte aber keine Bedeutung haben, da ich Dein Makro immer als erstes laufen lassen. Erst danach erstelle ich die Tabelle für den Spieltag.
Danke nochmals für Deine Geduld und Mühe.
AW: Testergebnis II
Tino
Hallo,
Fußball ist ganz schön kompliziert.
teste mal, fange aber beim 1.Spieltag an.
Option Explicit

Sub Spieltagübersicht()
Dim Bereich As Range, tBereich As Range
Dim meAr, LRow, LCol
Dim i As Integer
Dim NeuTab As Worksheet
Dim sFormel As String
Dim A As Long, tempCol As Long
Dim sSpieltag As String
Dim B As Long

If InStr(Sheets("Gesamt").Range("A2").Text, "ok") = 0 Then Exit Sub
sSpieltag = Trim$(Replace(Sheets("Gesamt").Range("A2").Text, "ok", "")) & ". Spieltag"

If IsNumeric(Application.Match(sSpieltag, Sheets("Übersicht").Columns(1), 0)) Then
 MsgBox "Speiltag ist schon in der Übersicht vorhanden!", vbInformation
 Exit Sub
End If

With Application
 .ScreenUpdating = False
 .EnableEvents = False
End With

 With Sheets("Gesamt")
    Set Bereich = .Range("A3:A20")
    Redim meAr(305, 6)
 
    For Each Bereich In Bereich
     
      Set tBereich = .Range(Bereich.Offset(0, 2), Bereich.Offset(0, 55))
    
       For A = 1 To 18
         
            
            For B = 1 + B To tBereich.Cells.Count - 1
             If tBereich(B) <> "" And tBereich(B) <> ":" Then
              LCol = B + 2
              B = B + 2
              Exit For
             End If
            Next B
           
           If IsNumeric(LCol) Then
            tempCol = tempCol + LCol
                Sheets("Übersicht").Range("B1").FormulaR1C1 = _
                "=SUMPRODUCT((R[1]C:R[500]C=""" & Bereich & """)*(R[1]C[2]:R[500]C[2]=""" & .Cells(2, LCol) & """))"
              If Sheets("Übersicht").Range("B1") = 0 Then
                    meAr(i, 0) = sSpieltag
                    meAr(i, 1) = Bereich
                    meAr(i, 2) = "gegen"
                    meAr(i, 3) = .Cells(2, LCol)
                    meAr(i, 4) = .Cells(tBereich.Row, LCol)
                    meAr(i, 5) = ":"
                    meAr(i, 6) = .Cells(tBereich.Row, LCol + 2)
                    i = i + 1
                    tempCol = tempCol + 1
                    If tempCol > 53 Then Exit For
               End If
                Sheets("Übersicht").Range("B1").Value = ""
                If tempCol > 53 Then Exit For
             Else
                Exit For
            End If
                    
        Next A
     tempCol = 0
     B = 0
    Next Bereich

 End With
Sheets("Übersicht").Range("B1").Value = ""
    Set NeuTab = Sheets("Übersicht")

    With NeuTab
        LRow = Application.Match(meAr(0, 0), .Columns(1), 0)
        If Not IsNumeric(LRow) Then
         LRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 2
         LRow = IIf(LRow = 3, 2, LRow)
        End If
        
        .Cells(LRow, 1).Resize(Ubound(meAr, 1) + 1, Ubound(meAr, 2) + 1) = meAr
        .Cells(LRow, 1).EntireColumn.Font.Bold = True
        .Cells(LRow, 1).EntireColumn.Font.ColorIndex = 23
        .Range(.Cells(LRow, 1), .Cells(LRow, 7)).EntireColumn.AutoFit
        .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp)).Offset(0, 7).FormulaR1C1 = _
        "=--LEFT(RC1,FIND(""."",RC1)-1)"
        
        'Sortieren 
        .Range("A2:H" & .Rows.Count).Sort .Range("H2"), xlAscending
        .Columns(8).Value = ""
        
        'Zwischenzeile einfügen 
        For LRow = .Cells(Rows.Count, 1).End(xlUp).Row - 1 To 2 Step -1
         If .Cells(LRow, 1) <> .Cells(LRow + 1, 1) Then
          .Cells(LRow + 1, 1).EntireRow.Insert
         End If
        Next LRow
        
    End With

With Application
 .ScreenUpdating = True
 .EnableEvents = True
End With
MsgBox "Daten wurden in die Übersicht aufgenommen!", vbInformation
End Sub


Gruß Tino

Laufzeitfehler 1004
Markus
Hallo,
bekomme ein schlechtes Gewissen.
Direkt bei Spieltag 1 gibt es einen Laufzeitfehler. Das Makro bleibt an folgender Stelle stehen:
Sheets("Übersicht").range("b1").FormularaR1C1 = _
"=SUMPRODUCT((R[1]C:R[500] ......"
AW: Laufzeitfehler 1004
Tino
Hallo,
wir bekommen es schon hin.
Option Explicit

Sub Spieltagübersicht()
Dim Bereich As Range, tBereich As Range
Dim meAr, LRow, LCol
Dim i As Integer
Dim NeuTab As Worksheet
Dim sFormel As String
Dim A As Long, tempCol As Long
Dim sSpieltag As String
Dim B As Long

If InStr(Sheets("Gesamt").Range("A2").Text, "ok") = 0 Then Exit Sub
sSpieltag = Trim$(Replace(Sheets("Gesamt").Range("A2").Text, "ok", "")) & ". Spieltag"

If IsNumeric(Application.Match(sSpieltag, Sheets("Übersicht").Columns(1), 0)) Then
 MsgBox "Speiltag ist schon in der Übersicht vorhanden!", vbInformation
 Exit Sub
End If

With Application
 .ScreenUpdating = False
 .EnableEvents = False
End With

 With Sheets("Gesamt")
    Set Bereich = .Range("A3:A20")
    Redim meAr(305, 6)
 
    For Each Bereich In Bereich
     
      Set tBereich = .Range(Bereich.Offset(0, 2), Bereich.Offset(0, 55))
    
       For A = 1 To 18
         
            
            For B = 1 + B To tBereich.Cells.Count - 1
             If tBereich(B) <> "" And tBereich(B) <> ":" Then
              LCol = B + 2
              B = B + 2
              Exit For
             End If
            Next B
           
           If IsNumeric(LCol) And B < tBereich.Cells.Count Then
            tempCol = tempCol + LCol
                Sheets("Übersicht").Range("B1").FormulaR1C1 = _
                "=SUMPRODUCT((R[1]C:R[500]C=""" & Bereich & """)*(R[1]C[2]:R[500]C[2]=""" & .Cells(2, LCol) & """))"
              If Sheets("Übersicht").Range("B1") = 0 Then
                    meAr(i, 0) = sSpieltag
                    meAr(i, 1) = Bereich
                    meAr(i, 2) = "gegen"
                    meAr(i, 3) = .Cells(2, LCol)
                    meAr(i, 4) = .Cells(tBereich.Row, LCol)
                    meAr(i, 5) = ":"
                    meAr(i, 6) = .Cells(tBereich.Row, LCol + 2)
                    i = i + 1
                    tempCol = tempCol + 1
                    If tempCol > 53 Then Exit For
               End If
                Sheets("Übersicht").Range("B1").Value = ""
                If tempCol > 53 Then Exit For
             Else
                Exit For
            End If
                    
        Next A
     tempCol = 0
     B = 0
    Next Bereich

 End With
Sheets("Übersicht").Range("B1").Value = ""
    Set NeuTab = Sheets("Übersicht")

    With NeuTab
        LRow = Application.Match(meAr(0, 0), .Columns(1), 0)
        If Not IsNumeric(LRow) Then
         LRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 2
         LRow = IIf(LRow = 3, 2, LRow)
        End If
        
        .Cells(LRow, 1).Resize(Ubound(meAr, 1) + 1, Ubound(meAr, 2) + 1) = meAr
        .Cells(LRow, 1).EntireColumn.Font.Bold = True
        .Cells(LRow, 1).EntireColumn.Font.ColorIndex = 23
        .Range(.Cells(LRow, 1), .Cells(LRow, 7)).EntireColumn.AutoFit
        .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp)).Offset(0, 7).FormulaR1C1 = _
        "=--LEFT(RC1,FIND(""."",RC1)-1)"
        
        'Sortieren 
        .Range("A2:H" & .Rows.Count).Sort .Range("H2"), xlAscending
        .Columns(8).Value = ""
        
        'Zwischenzeile einfügen 
        For LRow = .Cells(Rows.Count, 1).End(xlUp).Row - 1 To 2 Step -1
         If .Cells(LRow, 1) <> .Cells(LRow + 1, 1) Then
          .Cells(LRow + 1, 1).EntireRow.Insert
         End If
        Next LRow
        
    End With

With Application
 .ScreenUpdating = True
 .EnableEvents = True
End With
MsgBox "Daten wurden in die Übersicht aufgenommen!", vbInformation
End Sub


Gruß Tino

AW: Laufzeitfehler 1004
Markus
Hallo Tino,
Du bist ja guter Hoffnung. Fußball ist aber auch wirklich schwer. :-(
Der erste Spieltag hat jetzt nur noch 8 Spiele, obwohl ich den Spieltag komplett eingegeben habe (müssten also 9 Spiele sein).
AW: Laufzeitfehler 1004
Tino
Hallo,
liegt wohl eher daran, dass ich nicht richtig teste,
weil ich hier noch ein anders Projekt bin und Deins immer so dazwischen schiebe.
Option Explicit

Sub Spieltagübersicht()
Dim Bereich As Range, tBereich As Range
Dim meAr, LRow, LCol
Dim i As Integer
Dim NeuTab As Worksheet
Dim sFormel As String
Dim A As Long, tempCol As Long
Dim sSpieltag As String
Dim B As Long

If InStr(Sheets("Gesamt").Range("A2").Text, "ok") = 0 Then Exit Sub
sSpieltag = Trim$(Replace(Sheets("Gesamt").Range("A2").Text, "ok", "")) & ". Spieltag"

If IsNumeric(Application.Match(sSpieltag, Sheets("Übersicht").Columns(1), 0)) Then
 MsgBox "Speiltag ist schon in der Übersicht vorhanden!", vbInformation
 Exit Sub
End If

With Application
 .ScreenUpdating = False
 .EnableEvents = False
End With

 With Sheets("Gesamt")
    Set Bereich = .Range("A3:A20")
    Redim meAr(305, 6)
 
    For Each Bereich In Bereich
     
      Set tBereich = .Range(Bereich.Offset(0, 2), Bereich.Offset(0, 55))
    
       For A = 1 To 18
         
            
            For B = 1 + B To tBereich.Cells.Count
             If tBereich(B) <> "" And tBereich(B) <> ":" Then
              LCol = B + 2
              B = B + 2
              Exit For
             End If
            Next B
           Debug.Print tBereich(B).Address
           If IsNumeric(LCol) And B <= tBereich.Cells.Count Then
            
            tempCol = tempCol + LCol
                Sheets("Übersicht").Range("B1").FormulaR1C1 = _
                "=SUMPRODUCT((R[1]C:R[500]C=""" & Bereich & """)*(R[1]C[2]:R[500]C[2]=""" & .Cells(2, LCol) & """))"
              If Sheets("Übersicht").Range("B1") = 0 Then
                    meAr(i, 0) = sSpieltag
                    meAr(i, 1) = Bereich
                    meAr(i, 2) = "gegen"
                    meAr(i, 3) = .Cells(2, LCol)
                    meAr(i, 4) = .Cells(tBereich.Row, LCol)
                    meAr(i, 5) = ":"
                    meAr(i, 6) = .Cells(tBereich.Row, LCol + 2)
                    i = i + 1
                    tempCol = tempCol + 1
                    If tempCol > 53 Then Exit For
               End If
                Sheets("Übersicht").Range("B1").Value = ""
                If tempCol > 53 Then Exit For
             Else
                Exit For
            End If
                    
        Next A
     tempCol = 0
     B = 0
    Next Bereich

 End With
Sheets("Übersicht").Range("B1").Value = ""
    Set NeuTab = Sheets("Übersicht")

    With NeuTab
        LRow = Application.Match(meAr(0, 0), .Columns(1), 0)
        If Not IsNumeric(LRow) Then
         LRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 2
         LRow = IIf(LRow = 3, 2, LRow)
        End If
        
        .Cells(LRow, 1).Resize(Ubound(meAr, 1) + 1, Ubound(meAr, 2) + 1) = meAr
        .Cells(LRow, 1).EntireColumn.Font.Bold = True
        .Cells(LRow, 1).EntireColumn.Font.ColorIndex = 23
        .Range(.Cells(LRow, 1), .Cells(LRow, 7)).EntireColumn.AutoFit
        .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp)).Offset(0, 7).FormulaR1C1 = _
        "=--LEFT(RC1,FIND(""."",RC1)-1)"
        
        'Sortieren 
        .Range("A2:H" & .Rows.Count).Sort .Range("H2"), xlAscending
        .Columns(8).Value = ""
        
        'Zwischenzeile einfügen 
        For LRow = .Cells(Rows.Count, 1).End(xlUp).Row - 1 To 2 Step -1
         If .Cells(LRow, 1) <> .Cells(LRow + 1, 1) Then
          .Cells(LRow + 1, 1).EntireRow.Insert
         End If
        Next LRow
        
    End With

With Application
 .ScreenUpdating = True
 .EnableEvents = True
End With
MsgBox "Daten wurden in die Übersicht aufgenommen!", vbInformation
End Sub


Gruß Tino

Getestet
Markus
Na wenn das so ist. Bin ja mit einem Projekt schon überfordert.
Die ersten 5 Spieltage sind ok, beim 6 Spieltag fehlt ein Spiel.
"Wir" sind also auf einem guten Weg. :-)
Getestet
Markus
Na wenn das so ist. Bin ja mit einem Projekt schon überfordert.
Die ersten 5 Spieltage sind ok, beim 6 Spieltag fehlt ein Spiel.
"Wir" sind also auf einem guten Weg. :-)
Getestet
Markus
Na wenn das so ist. Bin ja mit einem Projekt schon überfordert.
Die ersten 5 Spieltage sind ok, beim 6 Spieltag fehlt ein Spiel.
"Wir" sind also auf einem guten Weg. :-)
AW: Getestet
Tino
Hallo,
und jetzt?
Option Explicit

Sub Spieltagübersicht()
Dim Bereich As Range, tBereich As Range
Dim meAr, LRow, LCol
Dim i As Integer
Dim NeuTab As Worksheet
Dim sFormel As String
Dim A As Long
Dim sSpieltag As String
Dim B As Long

If InStr(Sheets("Gesamt").Range("A2").Text, "ok") = 0 Then Exit Sub
sSpieltag = Trim$(Replace(Sheets("Gesamt").Range("A2").Text, "ok", "")) & ". Spieltag"

If IsNumeric(Application.Match(sSpieltag, Sheets("Übersicht").Columns(1), 0)) Then
 MsgBox "Speiltag ist schon in der Übersicht vorhanden!", vbInformation
 Exit Sub
End If

With Application
 .ScreenUpdating = False
 .EnableEvents = False
End With

 With Sheets("Gesamt")
    Set Bereich = .Range("A3:A20")
    Redim meAr(305, 6)
 
    For Each Bereich In Bereich
     
      Set tBereich = .Range(Bereich.Offset(0, 2), Bereich.Offset(0, 55))
    
       For A = 1 To 18
         
            
            For B = 1 + B To tBereich.Cells.Count
             If tBereich(B) <> "" And tBereich(B) <> ":" Then
              LCol = B + 2
              B = B + 2
              Exit For
             End If
            Next B

           If IsNumeric(LCol) And B <= tBereich.Cells.Count Then
            
               Sheets("Übersicht").Range("B1").FormulaR1C1 = _
                "=SUMPRODUCT((R[1]C:R[500]C=""" & Bereich & """)*(R[1]C[2]:R[500]C[2]=""" & .Cells(2, LCol) & """))"
              If Sheets("Übersicht").Range("B1") = 0 Then
                    meAr(i, 0) = sSpieltag
                    meAr(i, 1) = Bereich
                    meAr(i, 2) = "gegen"
                    meAr(i, 3) = .Cells(2, LCol)
                    meAr(i, 4) = .Cells(tBereich.Row, LCol)
                    meAr(i, 5) = ":"
                    meAr(i, 6) = .Cells(tBereich.Row, LCol + 2)
                    i = i + 1
               End If
                Sheets("Übersicht").Range("B1").Value = ""
             Else
                Exit For
            End If
                    
        Next A
     B = 0
    Next Bereich

 End With
Sheets("Übersicht").Range("B1").Value = ""
    Set NeuTab = Sheets("Übersicht")

    With NeuTab
        LRow = Application.Match(meAr(0, 0), .Columns(1), 0)
        If Not IsNumeric(LRow) Then
         LRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 2
         LRow = IIf(LRow = 3, 2, LRow)
        End If
        
        .Cells(LRow, 1).Resize(Ubound(meAr, 1) + 1, Ubound(meAr, 2) + 1) = meAr
        .Cells(LRow, 1).EntireColumn.Font.Bold = True
        .Cells(LRow, 1).EntireColumn.Font.ColorIndex = 23
        .Range(.Cells(LRow, 1), .Cells(LRow, 7)).EntireColumn.AutoFit
        .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp)).Offset(0, 7).FormulaR1C1 = _
        "=--LEFT(RC1,FIND(""."",RC1)-1)"
        
        'Sortieren 
        .Range("A2:H" & .Rows.Count).Sort .Range("H2"), xlAscending
        .Columns(8).Value = ""
        
        'Zwischenzeile einfügen 
        For LRow = .Cells(Rows.Count, 1).End(xlUp).Row - 1 To 2 Step -1
         If .Cells(LRow, 1) <> .Cells(LRow + 1, 1) Then
          .Cells(LRow + 1, 1).EntireRow.Insert
         End If
        Next LRow
        
    End With

With Application
 .ScreenUpdating = True
 .EnableEvents = True
End With
MsgBox "Daten wurden in die Übersicht aufgenommen!", vbInformation
End Sub


Gruß Tino

Zauberei und Hexerei
Markus
kann ich dazu nur sagen.
Es klappt und das super. Vielen vielen Dank für Deine Hilfe, Mühe und die Geduld.
Was möchtest Du denn für die Arbeit haben? Hast Du Dir das was überlegt?
Viele Grüße
Markus
ist ein Forum, nix.
Tino
Hallo,
dies ist ein Forum und daher will ich nichts haben.
Habe ja auch was über Fußball gelernt, auch wenn es bei mir nichts bringt.
Viel Spaß damit.
Gruß Tino
Zauberei und Hexerei
Markus
kann ich dazu nur sagen.
Es klappt und das super. Vielen vielen Dank für Deine Hilfe, Mühe und die Geduld.
Was möchtest Du denn für die Arbeit haben? Hast Du Dir das was überlegt?
Viele Grüße
Markus
Na, dann tausend Dank!
Markus

Links zu Excel-Dialogen

UserForm

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige