vor ein paar Tagen hat mir schon jemand bei dem Code geholfen
Sub Mischen()
Application.ScreenUpdating = False
Rows("1:1").Select
Selection.Delete Shift:=xlUp
Range("A1").Select
Dim col As New Collection
Dim i As Long, lngRnd As Long
Randomize
With Sheets("Mischen")
.Columns(2).Clear
For i = 1 To 209
col.Add i
Next
For i = 1 To 209
lngRnd = Rnd() * (col.Count - 1) + 1
.Cells(i, 2) = col(lngRnd) \ 12 + 1
col.Remove lngRnd
Next
End With
Columns("A:A").Select
Selection.Copy
Columns("B:B").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Rows("1:1").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.AutoFilter
Application.ScreenUpdating = True
End Sub
Es werden Teilnehmer eines Meetings gemischt umd gleiche Gruppen gut gemischt zu erreichen.Jetzt muss leider etwas angepasst werden und ich schaffs leider nicht alleine :-(
Da Teilnehmer absagen muss die Anzahl in Spalte 1 beachtet werden und es dürfen nur 10 Mann pro Gruppe bzw 12Mann (abendessen) und keine 2 oder 3 in der gleichen Gruppe...verständlich? :-))
Dateiupload ist dabei..das hilft glaube auch etwas!
https://www.herber.de/bbs/user/87875.xls
Danke und Gruß Christian