AW: Namen mit Zufallsgenerator sortieren
11.05.2004 22:30:05
Jens
Das hätte ich gerne gemacht. Ich darf nur leider nicht was ich machen kann , ist dir das komplette Makro zu zeigen, vielleicht kannst du etwas damit anfangen:
Option Explicit
Dim SourceRow As Integer
Dim SourceColl As Integer
Dim DestRow As Integer
Dim DestColl As Integer
Dim I As Integer
Sub BPE()
'mouse -> sanduhr
Application.Cursor = xlWait
'no screenupdate -> faster
Application.ScreenUpdating = False
'Tabellenblatt leeren
Worksheets("Berechnung").Range("A4:L500").Value = ""
'Berechnung der Dauerfrühschicht
SourceRow = 5
SourceColl = 8
DestRow = 5
DestColl = 2
Dim Dest As Range
Dim Source As Range
Worksheets("Berechnung").Activate
Set Dest = Worksheets("Berechnung").Range(Cells(DestRow, DestColl + 1), Cells(DestRow, DestColl + 1))
Worksheets("Namenliste").Activate
Set Source = Worksheets("Namenliste").Range(Cells(SourceRow, SourceColl), Cells(SourceRow, SourceColl))
Do
Dest.Value = Source.Value
DestRow = DestRow + 1
SourceRow = SourceRow + 1
Worksheets("Berechnung").Activate
Set Dest = Worksheets("Berechnung").Range(Cells(DestRow, DestColl + 1), Cells(DestRow, DestColl + 1))
Worksheets("Namenliste").Activate
Set Source = Worksheets("Namenliste").Range(Cells(SourceRow, SourceColl), Cells(SourceRow, SourceColl))
Loop Until Source.Value = ""
'Berechnung der Wechselschicht1
SourceRow = 5
SourceColl = 2
'If KWoche(18) Mod 2 = 0 Then
If KWoche(Now()) Mod 2 = 0 Then
'Bei geraden Wochen
Worksheets("Berechnung").Activate
Set Dest = Worksheets("Berechnung").Range(Cells(DestRow, DestColl + 1), Cells(DestRow, DestColl + 1))
Worksheets("Namenliste").Activate
Set Source = Worksheets("Namenliste").Range(Cells(SourceRow, SourceColl), Cells(SourceRow, SourceColl))
Do
Dest.Value = Source.Value
DestRow = DestRow + 1
SourceRow = SourceRow + 1
Worksheets("Berechnung").Activate
Set Dest = Worksheets("Berechnung").Range(Cells(DestRow, DestColl + 1), Cells(DestRow, DestColl + 1))
Worksheets("Namenliste").Activate
Set Source = Worksheets("Namenliste").Range(Cells(SourceRow, SourceColl), Cells(SourceRow, SourceColl))
Loop Until Source.Value = ""
'''''End If
'Berechnung der Sonderschicht
SourceRow = 5
SourceColl = 14
'''''If KWoche(Now()) Mod 2 = 0 Then
'Bei geraden Wochen
Worksheets("Berechnung").Activate
Set Dest = Worksheets("Berechnung").Range(Cells(DestRow, DestColl + 1), Cells(DestRow, DestColl + 1))
Worksheets("Namenliste").Activate
Set Source = Worksheets("Namenliste").Range(Cells(SourceRow, SourceColl), Cells(SourceRow, SourceColl))
Do
Dest.Value = Source.Value
DestRow = DestRow + 1
SourceRow = SourceRow + 1
Worksheets("Berechnung").Activate
Set Dest = Worksheets("Berechnung").Range(Cells(DestRow, DestColl + 1), Cells(DestRow, DestColl + 1))
Worksheets("Namenliste").Activate
Set Source = Worksheets("Namenliste").Range(Cells(SourceRow, SourceColl), Cells(SourceRow, SourceColl))
Loop Until Source.Value = ""
'''''End If
'Berechnung der Dauerspätschicht
SourceRow = 5
SourceColl = 11
DestRow = 5
DestColl = 4
'''''If KWoche(Now()) Mod 2 = 0 Then
'Bei geraden Wochen
Worksheets("Berechnung").Activate
Set Dest = Worksheets("Berechnung").Range(Cells(DestRow, DestColl + 1), Cells(DestRow, DestColl + 1))
Worksheets("Namenliste").Activate
Set Source = Worksheets("Namenliste").Range(Cells(SourceRow, SourceColl), Cells(SourceRow, SourceColl))
Do
Dest.Value = Source.Value
DestRow = DestRow + 1
SourceRow = SourceRow + 1
Worksheets("Berechnung").Activate
Set Dest = Worksheets("Berechnung").Range(Cells(DestRow, DestColl + 1), Cells(DestRow, DestColl + 1))
Worksheets("Namenliste").Activate
Set Source = Worksheets("Namenliste").Range(Cells(SourceRow, SourceColl), Cells(SourceRow, SourceColl))
Loop Until Source.Value = ""
'''''End If
'Berechnung der Wechselschicht2
SourceRow = 5
SourceColl = 5
'''''If KWoche(Now()) Mod 2 = 0 Then
'Bei geraden Wochen
Worksheets("Berechnung").Activate
Set Dest = Worksheets("Berechnung").Range(Cells(DestRow, DestColl + 1), Cells(DestRow, DestColl + 1))
Worksheets("Namenliste").Activate
Set Source = Worksheets("Namenliste").Range(Cells(SourceRow, SourceColl), Cells(SourceRow, SourceColl))
Do
Dest.Value = Source.Value
DestRow = DestRow + 1
SourceRow = SourceRow + 1
Worksheets("Berechnung").Activate
Set Dest = Worksheets("Berechnung").Range(Cells(DestRow, DestColl + 1), Cells(DestRow, DestColl + 1))
Worksheets("Namenliste").Activate
Set Source = Worksheets("Namenliste").Range(Cells(SourceRow, SourceColl), Cells(SourceRow, SourceColl))
Loop Until Source.Value = ""
''''End If
'--------------AB HIER BERECHNUNG DER UNGERADEN WOCHE-----------------------------------------------
Else
'Bei ungeraden Wochen
'Berechnung der Dauerspätschicht
SourceRow = 5
SourceColl = 11
DestRow = 5
DestColl = 2
'Dim Dest As Range
'Dim Source As Range
Worksheets("Berechnung").Activate
Set Dest = Worksheets("Berechnung").Range(Cells(DestRow, DestColl + 1), Cells(DestRow, DestColl + 1))
Worksheets("Namenliste").Activate
Set Source = Worksheets("Namenliste").Range(Cells(SourceRow, SourceColl), Cells(SourceRow, SourceColl))
Do
Dest.Value = Source.Value
DestRow = DestRow + 1
SourceRow = SourceRow + 1
Worksheets("Berechnung").Activate
Set Dest = Worksheets("Berechnung").Range(Cells(DestRow, DestColl + 1), Cells(DestRow, DestColl + 1))
Worksheets("Namenliste").Activate
Set Source = Worksheets("Namenliste").Range(Cells(SourceRow, SourceColl), Cells(SourceRow, SourceColl))
Loop Until Source.Value = ""
'Berechnung der Wechselschicht1
SourceRow = 5
SourceColl = 2
'''''If KWoche(Now()) Mod 2 = 0 Then
'Bei ungeraden Wochen
Worksheets("Berechnung").Activate
Set Dest = Worksheets("Berechnung").Range(Cells(DestRow, DestColl + 1), Cells(DestRow, DestColl + 1))
Worksheets("Namenliste").Activate
Set Source = Worksheets("Namenliste").Range(Cells(SourceRow, SourceColl), Cells(SourceRow, SourceColl))
Do
Dest.Value = Source.Value
DestRow = DestRow + 1
SourceRow = SourceRow + 1
Worksheets("Berechnung").Activate
Set Dest = Worksheets("Berechnung").Range(Cells(DestRow, DestColl + 1), Cells(DestRow, DestColl + 1))
Worksheets("Namenliste").Activate
Set Source = Worksheets("Namenliste").Range(Cells(SourceRow, SourceColl), Cells(SourceRow, SourceColl))
Loop Until Source.Value = ""
'''''End If
'Berechnung der Sonderschicht
SourceRow = 5
SourceColl = 14
'''''If KWoche(Now()) Mod 2 = 0 Then
'Bei ungeraden Wochen
Worksheets("Berechnung").Activate
Set Dest = Worksheets("Berechnung").Range(Cells(DestRow, DestColl + 1), Cells(DestRow, DestColl + 1))
Worksheets("Namenliste").Activate
Set Source = Worksheets("Namenliste").Range(Cells(SourceRow, SourceColl), Cells(SourceRow, SourceColl))
Do
Dest.Value = Source.Value
DestRow = DestRow + 1
SourceRow = SourceRow + 1
Worksheets("Berechnung").Activate
Set Dest = Worksheets("Berechnung").Range(Cells(DestRow, DestColl + 1), Cells(DestRow, DestColl + 1))
Worksheets("Namenliste").Activate
Set Source = Worksheets("Namenliste").Range(Cells(SourceRow, SourceColl), Cells(SourceRow, SourceColl))
Loop Until Source.Value = ""
'''''End If
'Berechnung der Dauerfrühschicht
SourceRow = 5
SourceColl = 8
DestRow = 5
DestColl = 4
'''''If KWoche(Now()) Mod 2 = 0 Then
Worksheets("Berechnung").Activate
Set Dest = Worksheets("Berechnung").Range(Cells(DestRow, DestColl + 1), Cells(DestRow, DestColl + 1))
Worksheets("Namenliste").Activate
Set Source = Worksheets("Namenliste").Range(Cells(SourceRow, SourceColl), Cells(SourceRow, SourceColl))
Do
Dest.Value = Source.Value
DestRow = DestRow + 1
SourceRow = SourceRow + 1
Worksheets("Berechnung").Activate
Set Dest = Worksheets("Berechnung").Range(Cells(DestRow, DestColl + 1), Cells(DestRow, DestColl + 1))
Worksheets("Namenliste").Activate
Set Source = Worksheets("Namenliste").Range(Cells(SourceRow, SourceColl), Cells(SourceRow, SourceColl))
Loop Until Source.Value = ""
'''''End If
'Berechnung der Wechselschicht2
SourceRow = 5
SourceColl = 5
'''''If KWoche(Now()) Mod 2 = 0 Then
'Bei ungeraden Wochen
Worksheets("Berechnung").Activate
Set Dest = Worksheets("Berechnung").Range(Cells(DestRow, DestColl + 1), Cells(DestRow, DestColl + 1))
Worksheets("Namenliste").Activate
Set Source = Worksheets("Namenliste").Range(Cells(SourceRow, SourceColl), Cells(SourceRow, SourceColl))
Do
Dest.Value = Source.Value
DestRow = DestRow + 1
SourceRow = SourceRow + 1
Worksheets("Berechnung").Activate
Set Dest = Worksheets("Berechnung").Range(Cells(DestRow, DestColl + 1), Cells(DestRow, DestColl + 1))
Worksheets("Namenliste").Activate
Set Source = Worksheets("Namenliste").Range(Cells(SourceRow, SourceColl), Cells(SourceRow, SourceColl))
Loop Until Source.Value = ""
End If
'Zufällig sortieren in Spalte C
Sub sortieren()
Dim z As Integer
Dim arr(800, 0) As Variant
Dim s As Integer
Dim w As Integer
Dim az As Integer
z = Range("C65536").End(xlUp).Row
For s = 5 To 8000
w = Int((z - 5 + 1) * Rnd + 5)
If Cells(w, 1) <> "" Then
arr(az, 0) = Cells(w, 1)
az = az + 1
Cells(w, 1).Delete Shift:=xlUp
End If
Next s
Range("C5", "C" & z) = arr
End Sub
'Ausdrucken
'For I = 3 To Worksheets.Count
' Worksheets(I).PrintOut
'Next I
'--------------------------------------------------------------------------------------------
'mouse -> normal
Application.Cursor = xlDefault
'no screenupdate -> faster / wieder an
Application.ScreenUpdating = True
End Sub
'Berechnung der Kalenderwoche
Function KWoche(d)
Dim t
t = DateSerial(Year(d + (8 - Weekday(d)) Mod 7 - 3), 1, 1)
KWoche = ((d - t - 3 + (Weekday(t) + 1) Mod 7)) \ 7 + 1
End Function