AW: Lösung zu 96 Personen
15.02.2016 14:10:31
Piet
Hallo Sascha
anbei ein 2. Makro für 88 Teilnehmer, ich musste es manuell aendern.
In der Zelle M109 (ausgeblendet, bitte einblenden) steht die Zahl 4656
Sie muss in 3916 geaendert werden!! Sonst funktioniert das Makro nicht.
Sie gibt dem Makro den Restwert zurück wenn 87 Zahlen ausgefüllt sind.
Am besten das alte Makro nicht überschreiben, ein neues Modulblatt anlegen uns
hinein kopieren. Dann kann der Button wahlweise das Makro 1 oder 2 ausführen.
Die zusaetzlichen Prüf-Routinen habe ich noch nicht geschrieben. Mach es aber
noch weil es mich selbst interessiert ob ich das technisch schaffen kann.
mfg Piet
Option Explicit '12.2.2016 Piet für Herber Forum
'** geaendert für 88 Teilnehmer !! Restwert Basis 3916
'** in Zelle M109 (ausgeblendet) muss 3916 gesetzt werden
Dim rFind As Object 'Objekt Vatiabel (prüfen)
Dim xAdr, xBer, pBer 'x-Anfang, x-Bereich, Prüf-Bereich
Dim sp, ze, x, xx 'Spalten, Zeilen, x-Wert, old X
Const TiLi = "U5" 'Teilnehmer zu Tisch-Nr, Moderator "Ja"
Const TNLi = "AH5" 'Teilnehmer zu Teilnehmer (doppelt)
'Zufallsverteilung der Teilnehmer an 12 Tischen (10 Runden)
'2. Lösung mit Shift Funktion (x-Wert wird vorgeladen)
'prüft noch nicht ob Teilnehmer sich doppelt treffen.
Sub Zufallsverteilung_88_Teilnehmer()
Dim TiNr, tz, k, Zahl, flg, wz 'Zaehler
With Worksheets("Zufallsliste (3)") 'Zufall 3
Start: 'Neustart bei endlos Wiederholung
.Range("C5:N84").ClearContents 'Zufall Tabelle
.Range("U5:AE105").ClearContents 'Hilfsliste 1
.Range("AH5:AQ105").ClearContents 'Hilfsliste 2
'Do Loop Schleife für 10 Runden
Do Until k = 10
k = k + 1 'k=Zaehler für Do Loop ; xAdr=Array mit Anf-Adressen
xAdr = Application.Choose(k, "C5", "C13", "C21", "C29", "C37", "C45", "C53", "C61", "C69", " _
C77")
xBer = .Range(xAdr).Resize(8, 12).Address
wz = 0 'Wiederholzaehler (endlos Schutz)
'Zufallsverteilung für Runde 1-10 (10 Blöcke)
For ze = 1 To 8: tz = 1 'Zeilen 1 - 8
For sp = 1 To 12 'Spalte C - N
'Tisch-Nr berechnen, mit Umrechnung ab ze > 4
If sp = 3 Or sp = 5 Or sp = 7 Or sp = 9 Or sp = 11 Then tz = tz + 1
If ze 1000 Then End
x = Int(89 * Rnd): flg = Empty
If x = 0 Or x > 88 Then GoTo rd1
'letzte Zahl manuell auswerten
Zahl = .[c120].Cells(1, k).Value
xx = .Range(xAdr).Cells(ze, sp)
If ze = 8 And sp = 11 Then _
If Zahl > 0 And Zahl
Sub vorprüfung: 'Prüfung auf doppelte Werte
' If Left(flg, 4) = "dopp" Then GoTo rd1
'Moderator über Shift Funktion setzen (mit "Ja" Prüfung)
If .Range(xAdr).Cells(ze, sp).Interior.ColorIndex > 1 Then
'war Teilnehmer bereits Moderator "Ja" ?
If .Range(TiLi).Cells(x, 1) = "Ja" Then GoTo rd1
'Moderater notieren in Runde: 1,3,5,7,9
If k = 1 Or k = 3 Or k = 5 Or k = 7 Or k = 9 Then
.Range(TiLi).Cells(x, 1) = "Ja" 'Moderastor "Ja"
.Range(xAdr).Cells(ze + 8, sp + 1) = x 'x-Wert
ElseIf k = 5 And sp = 10 Then Exit For
Next sp
Next ze
Loop
End With
Ende:
If NoMsg "No" Then MsgBox "alles gefüllt - Moderator Prüfung !!"
Exit Sub
'********* Sub-Programm Prüfung **********
'*** Vorerst deaktiviert (fehler in Auswertung)
vorprüfung: 'Prüfung auf doppelte Werte
Return
With Worksheets("Zufallsliste (3)")
'Prüfung auf dopppelten Tisch zum Teilnehmer
pBer = .Range(TiLi).Cells(x, 2).Resize(1, 10).Address
Set rFind = .Range(pBer).Find(What:=TiNr, LookAt:=xlWhole)
If Not rFind Is Nothing Then flg = "dopp T": Return
Return
'Prüfung auf dopppelte Person zum Teilnehmer
pBer = .Range(TNLi).Cells(x, 1).Resize(1, 10).Address
Set rFind = .Range(pBer).Find(What:=x, LookAt:=xlWhole)
If Not rFind Is Nothing Then flg = "dopp P"
Return
End With
End Sub