Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1748to1752
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
Inhaltsverzeichnis

Gruppenauslosung erweitern VBA

Gruppenauslosung erweitern VBA
29.03.2020 17:09:35
Fritz_W
Hallo Forumsbesucher,
in der Recherche bin ich auf die verlinkte Arbeitsmappe gestoßen, in der sich nach dem Ziufallsprinzip Gruppen zusammenstellen lassen. Ich möchte nun - wie in der Mappe beschrieben, die Möglichkeiten der Gruppenzusammenstellung erweitern.
Für Eure Hilfen bei der Realisierung dieses Vorhabens im Voraus besten Dank.
mfg
Fritz
https://www.herber.de/bbs/user/136216.xlsm

4
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Gruppenauslosung erweitern VBA
29.03.2020 23:42:18
Barbara
Hi Fritz,
konnte es nicht lassen. Hier mein Code zu Deiner Gruppenauslosung.
Die Anzahl der Gruppen musst Du in C1 schreiben.
Die Anzahl der Freilose musst Du darunter in C2 schreiben.
Das kannst Du aber im Makro individuell einstellen.
Ebenso den Beginn der Mannschaftsliste und die Liste der Gruppen.

Sub Auslosung()
Dim rMannschaft1 As Range, rGruppe1 As Range
Dim lGruppen As Long, lSetz As Long, lMannschaften As Long
Dim i As Long, lZufall As Long, sZwischen As String
Set rMannschaft1 = Range("B2")  'Name der ersten Mannschaft
Set rGruppe1 = Range("F5")      'Zelle "Gruppe 1"
'Abfrage
lGruppen = Range("C1")          'Anzahl Gruppen
lSetz = Range("C2")             'Anzahl Setzmannschaften
Set rMannschaft1 = Range(rMannschaft1, Cells(Rows.Count, rMannschaft1.Column).End(xlUp)) _
lMannschaften = rMannschaft1.Rows.Count
Set rGruppe1 = rGruppe1.Resize(, lGruppen)
'Gruppenbereich und Randzellen rechts und darunger werden gelöscht
rGruppe1.Resize(rGruppe1(lMannschaften).Row - rGruppe1.Row + 3, lGruppen + 1).Clear
'Schreiben Gruppenüberschrift
For i = 1 To lGruppen
rGruppe1(i) = "Gruppe " & i
Next i
'Alle Mannschaften zu den Gruppen kopieren
Set rGruppe1 = rGruppe1.Offset(1)
For i = 1 To lMannschaften
rGruppe1(i) = rMannschaft1(i)
Next i
'Alle nicht gesetzten Mannschaften mischen
Randomize Timer
For i = lSetz + 1 To lMannschaften
lZufall = Int((lMannschaften - i + 1) * Rnd + i)
sZwischen = rGruppe1(i).Text
rGruppe1(i) = rGruppe1(lZufall)
rGruppe1(lZufall) = sZwischen
Next i
End Sub
LGB
Anzeige
Top umgesetzt
30.03.2020 09:09:44
Fritz_W
Hallo Barbara,
vielen Dank für Deine Hilfe, Du hast mit Deinem Code meine Vorstellungen top umgesetzt.
Große Klasse!
Beste Grüße
Fritz
AW: Top umgesetzt
30.03.2020 13:06:04
Barbara
Bitte gerne,
du sollst damit auch top Erfolge haben.
@Barbara
30.03.2020 14:28:36
Fritz_W
Hallo Barbara,
ich möchte meinen Dank bzw. mein Kompliment noch etwas konkretisieren:
Der Code ist so klar strukturiert (und zudem kommentiert), dass ich mit meinen sehr bescheidenen VBA-Kenntnissen diesen (zumindest in Teilen) verstehen und auch anpassen kann.
Gruß
Fritz

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige