Hallo zusammen,

Ich hab als absoluter Anfänger ein kleines Projekt angefangen auf Arbeit.

Ich hab zwar alles gelöst wie ich mir das Vorstelle, aber ich bin sicher das man gerade den Zufalls Generator eleganter und Systemseitig schneller lösen könnte.

Da ich nicht wirklich fündig geworden bin über Googel hab ich mir selber etwas zusammen gezimmert und bin selber erstaunt wie gut es funtioniert =)

Kurze Einleitung zur Tabelle:

Es ist eine Rotationsliste für Teams.

Am Tag Rotieren die Kollegen 4 mal anhand einer Liste. Diese Liste soll per Zufall die Einteilung generieren.

Prämissen sind dabei, das der Kollege den Arbeitsplatz kann (Datenbank abfrage über ZählenWenn versteckt im Hintergrund) und diesen auch noch nicht gemacht hatte an diesem Tag.

Zusätzlich sollte die Tabelle flexibel für verschiedene Team größen funktionieren, da die Teams Stark in der Mitarbeiter Anzahl und Arbeitsplatz Anzahl varrieren.

Habt Gnade mit meiner Codierung, diese Tabelle ist ernsthaft die erste die ich mit VBA aufbaue, bin für Tipp und tricks dankbar und wenn jemand das ganze verschnellern kann wäre das echt klasse =D

Ein Weiterer Grund für diesen Post, ist das ich kaum was zum Zufalls generator etwas gefunden habe (oder einfach die falschen Schlagwörter verwende), falls jemand ein ähnliches Thema hat kann er meine Variante als Anhaltspunkt verwenden

Voraus vielen Dank

Private Sub Randomizer()
        Application.Run "Admin.PasswordOFF" 'Schaltet lediglich den Kompletten Passwortschutz aus damit niemand die Datenbank dahinter kaputt machen kann
                Application.ScreenUpdating = False
                Sheets("Datenbank").Visible = True
                Sheets("Einstellungen").Visible = True
                Application.Run "Sheetname.Lock" 'Benennt die Aktuelle Tabelle um immer auf die richtige zuzugreifen. Da für jeden Tag ein neues Blatt verwendet wird
                Application.Run "Randomizer.CopyPresent" 'Kopiert Kollegen die mittels Drop Down auf Anwesend gesetzt wurden in die Datenbank
                Application.Run "Randomizer.DatabaseBuild" 'Baut im Hintergrund die Abfrage auf die auf den aktuellen Tag zugreift. Zählenwenn ist hierbei Stark vertreten.

        If Sheets("Einstellungen").Range("StateFirstIsLast") = "Aus" Then 'Manche Teams fangen in der 1. Runde an mit der Arbeit, die sie am Vortag als letztes hatten. Mit dieser Abfrage prüft es die "Einstellungen" diesbezüglich
                Sheets("Random").Range("Runde1").Copy
                Sheets("Datenbank").Range("S1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                        :=False, Transpose:=False
                        Application.CutCopyMode = False
                        ActiveWorkbook.Names.Add Name:="Dataround", RefersToR1C1:=Selection

                Range("D2").FormulaR1C1 = "=RAND()*20"
                        Selection.AutoFill Destination:=Range("D2:D21"), Type:=xlFillDefault
                        ActiveSheet.Range("$C$1:$D$21").AutoFilter Field:=1, Criteria1:="<>"

                Dim hausbruchcount As Long
    
                Do
                        hausbruchcount = hausbruchcount + 1
                        If hausbruchcount > 1000 Then
                                MsgBox "Endlos-Schleife! Befehl wird abgebrochen. Manueller Eintrag Notwendig in Runde 1 oder Bedingungen anpassen."
                                Exit Do
                        End If
        
                ActiveSheet.Range("$C$1:$D$21").AutoFilter Field:=1
                        Range("Dataround").Copy
                        Sheets("Locked").Range("Runde1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                                :=False, Transpose:=False
                Application.Run "Randomizer.NewSequence" 'Sortiert lediglich den Filter neu, damit die =Rand Zahlen neu berechnet werden
                Call RNGcopyR1 'Kopiert die Mitarbeiter, Code leg ich separat ab
          
          
               'Wiederholt solange bis die Prämissen erfüllt sind (Alle können den zugeteilten Arbeitsplatz und niemand ist Doppelt eingetragen)
                Loop Until Sheets("Datenbank").Range("G23") = "1" And Sheets("Datenbank").Range("N1") = "0"

                Else: End If
        
        On Error GoTo 1
                ActiveWorkbook.Worksheets("Datenbank").Names("DataRound").Delete
    
1    Err.Clear
        
 'Prozedur wiederholt sich jetzt noch 3 mal
    Sheets("Locked").Range("Runde2").Copy
    Sheets("Datenbank").Range("S1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
                ActiveWorkbook.Names.Add Name:="Dataround", RefersToR1C1:=Selection

    Dim iausbruchcount As Long
    
    Do
        iausbruchcount = iausbruchcount + 1
        If iausbruchcount > 1000 Then
            MsgBox "Endlos-Schleife! Befehl wird abgebrochen. Manueller Eintrag Notwendig in Runde 2 oder Bedingungen anpassen."
            Exit Do
        End If
        
    ActiveSheet.Range("$C$1:$D$21").AutoFilter Field:=1
                Range("Dataround").Copy
                Sheets("Locked").Range("Runde2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                        :=False, Transpose:=False
    Application.Run "Randomizer.NewSequence"
    Call RNGcopyR2
          
    Loop Until Sheets("Datenbank").Range("H23") = "1" And Sheets("Datenbank").Range("O1") = "0"
          
          
    Sheets("Locked").Range("Runde3").Copy
                Sheets("Datenbank").Range("S1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                        :=False, Transpose:=False
          
        Dim jausbruchcount As Long
        
    Do
        jausbruchcount = jausbruchcount + 1
        If jausbruchcount > 1000 Then
            MsgBox "Endlos-Schleife! Befehl wird abgebrochen. Manueller Eintrag Notwendig in Runde 3 oder Bedingungen anpassen."
            Exit Do
        End If
        
        
    ActiveSheet.Range("$C$1:$D$21").AutoFilter Field:=1
                Range("Dataround").Copy
                Sheets("Locked").Range("Runde3").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                        :=False, Transpose:=False
    Application.Run "Randomizer.NewSequence"
    Call RNGcopyR3
          
        Loop Until Sheets("Datenbank").Range("I23") = "1" And Sheets("Datenbank").Range("P1") = "0"

    Sheets("Locked").Range("Runde4").Copy
    Sheets("Datenbank").Range("S1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

        Dim kausbruchcount As Long
    
    Do
        kausbruchcount = kausbruchcount + 1
        If kausbruchcount > 1000 Then
            MsgBox "Endlos-Schleife! Befehl wird abgebrochen. Manueller Eintrag Notwendig in Runde 4 oder Bedingungen anpassen."
            Exit Do
        End If
        
        
    ActiveSheet.Range("$C$1:$D$21").AutoFilter Field:=1
                Range("Dataround").Copy
                Sheets("Locked").Range("Runde4").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                        :=False, Transpose:=False
    Application.Run "Randomizer.NewSequence"
    Call RNGcopyR4
          
    Loop Until Sheets("Datenbank").Range("J23") = "1" And Sheets("Datenbank").Range("Q1") = "0"
    
        ActiveSheet.Range("$C$1:$D$21").AutoFilter Field:=1
                Range("C2:D21").Clear
                ActiveWorkbook.Names("Dataround").Delete
                Application.Run "Randomizer.ClearDataBase" 'Löscht die zuvor aufgebaute Datenbank damit am nächsten Tag nicht die falsche Tabelle abgefragt wird
    
        Sheets("Locked").Range("A1").select
                Application.Run "Sheetname.Unlock"
        Application.ScreenUpdating = True
        Sheets("Datenbank").Visible = False
        Application.Run "Admin.PasswordOn"
    End Sub

Sub RNGcopyR1()

Sheets("Datenbank").select

If Not IsEmpty(Range("C2").Value) Then
    Range("C2").Copy
    Call RNGPasteR1
        
    Else: End If


Sheets("Datenbank").select
If Not IsEmpty(Range("C3").Value) Then
    Range("C3").Copy
    Call RNGPasteR1
    
    Else: End If

'usw bis max 20 Kollegen kopiert sind

Sub RNGPasteR1()

    Sheets("Random").select
    
    On Error GoTo 2
    If IsEmpty(Range("AP1R1").Value) Then
        Range("AP1R1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        GoTo 1
    Else: End If
        
    On Error GoTo 2
    If IsEmpty(Range("AP2R1").Value) Then
        Range("AP2R1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        GoTo 1
        Else: End If

'Ebenso bis alle Arbeitsplätze belegt sind. "AP2R1" sind die einzeln benannte Zellen um flexibel die Tabelle zu bewegen ohne jedesmal den Zielort in den Makros anzupassen
'Sobald ein Name nicht verfügbar ist bekommt er ein Fehler und bricht diesen Prozess ab. Dementsprechend wird der Mitarbeiter der noch übrig ist ignoriert