HERBERS Excel-Forum - die Beispiele

Thema: Spielplan generieren

Home

Gruppe

Allgemein

Problem

Es wird ein Spielplan generiert. In einer neuen Arbeitsmappe werden die Spiele eingetragen.

Lösung
Geben Sie den Code in ein Standardmodul ein und weisen Sie ihn einer Schaltfläche zu.
StandardModule: Modul1

Sub Main()
   Dim rngTeams As Range, rngPairs As Range
   Dim iRow As Integer, iCount As Integer
   Application.ScreenUpdating = False
   Range("C:E").ClearContents
   iRow = Cells(Rows.Count, 1).End(xlUp).Row
   Set rngTeams = Range(Cells(2, 1), Cells(iRow, 1))
   iCount = rngTeams.Cells.Count
   Call Paarungen(rngTeams, iCount)
   Set rngPairs = Range("C1").CurrentRegion
   Call PlanAnlegen(rngPairs, iCount)
   Application.ScreenUpdating = True
End Sub

Sub Paarungen(rng As Range, iCount As Integer)
   Dim iRow As Integer, iA As Integer, iB As Integer, iC As Integer, iD As Integer
   Dim bln As Boolean
   iRow = 1
   For iA = 1 To iCount
      For iB = iA To iCount
         If iA <> iB Then
            bln = Not bln
            If bln Then
               Cells(iRow, 3).Value = rng(iA)
               Cells(iRow, 4).Value = rng(iB)
            Else
               Cells(iRow, 4).Value = rng(iA)
               Cells(iRow, 3).Value = rng(iB)
            End If
            Cells(iRow, 5).Value = 0
            iRow = iRow + 1
         End If
      Next iB
   Next iA
End Sub

Sub PlanAnlegen(rng As Range, iCount As Integer)
   Dim rngCellA As Range, rngCellB As Range, rngAct As Range
   Dim iRow As Integer, iCounter As Integer, iAct As Integer
   Dim bln As Boolean

   Workbooks.Add 1
   Range("A1").Value = "Spielplan"
   For iRow = 3 To (iCount + 1) * (iCount + 1) / 2 Step (iCount / 2) + 2
      iCounter = iCounter + 1
      Cells(iRow, 1).Value = iCounter & ". Spieltag"
      Range(Cells(iRow + 1, 1), Cells(iRow + (iCount - 1) / 2, 2)).Name = "Tag" & iCounter
   Next iRow
   For iCounter = 1 To iCount - 1
      For Each rngAct In rng.Columns(1).Cells
         If rngAct.Offset(0, 2).Value = 0 Then
            Set rngCellA = Range("Tag" & iCounter).Find(rngAct.Value, LookIn:=xlValues, lookat:=xlWhole)
            Set rngCellB = Range("Tag" & iCounter).Find(rngAct.Offset(0, 1).Value, LookIn:=xlValues, lookat:=xlWhole)
            If rngCellA Is Nothing And rngCellB Is Nothing Then
               iAct = 1
               Do Until IsEmpty(Range("Tag" & iCounter).Columns(1).Cells(iAct))
                  iAct = iAct + 1
               Loop
               Range("Tag" & iCounter).Cells(iAct, 1).Value = rngAct.Value
               Range("Tag" & iCounter).Cells(iAct, 2).Value = rngAct.Offset(0, 1).Value
               rngAct.Offset(0, 2).Value = 1
            End If
         End If
      Next rngAct
   Next iCounter
   Columns.AutoFit
End Sub

Beiträge aus dem Excel-Forum zu den Themen Allgemein und Liste

Wenn Feld leer, dann Auswahlliste EK Liste als eigene XLSX
verschiedene Maillisten je Auswahl aufrufen Todo-Liste sortieren
Namensliste 2 mit Formeln ableiten Anzeigename aus Outlook-Verteilerliste auslesen
Sonderzeichen auflisten Tabellenblätter nach Liste erstellen
Listen vergleichen Zelle färben wenn Wert in Liste vorkommt
e-Maladressen aus einer Liste daten lesen Doppelte Beiträge in Liste nur einmal auswählen
Zellen aus Liste in Spalten korrekt umsortieren Daten Auflisten
Gewicht in Speditionspreisliste finden Texte aus einer Liste sammeln
Abhängige Dropdown Listen mittels VBA Rangliste nach Altersklasse
Liste mit mehreren Einträgen ausfiltern Listenfeld in Userform Markierung aufheben
Doppelte anlisten Automatisch Liste erstellen
Datum in Listenfeld auswählen Liste (Gültigkeit,DropDown,etc) mehrere Kriterien
Auswahlliste AutoFilter-Auswahlliste per VBA auslesen
Liste automatisch neu erstellen und umsortieren Liste erstellen, aber wie ??
Top 10 Liste ausfiltern liste
Probleme mit Gültigkeitsliste Listen zusammenfassen - Daten verschwinden
Leerzeilen im Dropdown (Liste) - Menü Suche Makro: Zellenwert anh. Liste alle 15Sek.änd.
Anzeige eines Teilstrings in der Gültigkeitsliste Tabelle über Listenfeld füllen
Unterschiedliche Einträge herausfiltern+auflisten Verlassen von Auswahllisten
Eintrag in Liste finden Listen kombinieren, zusammenführen und erweitern
Werte aus Liste in x Blätter Nach Dateiumbenennung listet mein Zähler flasch
Daten von Listenfeld in Tabelle Auswahl aus Liste
VBA-Gesamtliste, gibt es so etwas? Frage an Renne,Diagramm mit mehrern Auswahllisten
Listenfeld laden, Mappe ohne speichern schliessen? Zwei Listen vergleichen
Stückliste Allgemeine Frage zur Fehlerbehandlung