Thema Datum  Von Nutzer Rating
Antwort
Rot Zufalls Einteilung mit Prämissen verbessern
 06.06.2018 21:19:12 Khaos
NotSolved
06.06.2018 21:21:42 Khaos
NotSolved

Ansicht des Beitrags:
Von:
Khaos		 Datum:
06.06.2018 21:19:12		 Views:
1228		 Rating:
     
Antwort:
  Ja
Thema:
Zufalls Einteilung mit Prämissen verbessern

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

 

?
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
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

 

?
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
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

 

Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:
WYSIWYG-Editor, ctl00_Content_editor1



  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
Rot Zufalls Einteilung mit Prämissen verbessern
 06.06.2018 21:19:12 Khaos
NotSolved
06.06.2018 21:21:42 Khaos
NotSolved