エクセルでランダムな並べ替え

質問

パソコン初心者です。エクセル９７で当番表を作成しました。列に仕事名、行に名前（漢字）を入力しました。毎月、役割当番を変更したいのですが、ランダムに並べ替えをする方法がわかりません。どうかよろしくお願いします。

回答No.10

ka_na_de · ベストアンサー

ka_na_deです。

＃９のマクロでとりあえず前月の仕事と
重複しない割り当てが可能です。

しかし、重大な欠陥がありました。
それは、スタッフによって仕事の掛け持ち数に偏りが
できてしまうというものです。

その部分を改良しました。
できるかぎり、掛け持ち数に偏りが出ないように
再計算を繰り返します。
解が得られない場合は徐々に、掛け持ちのばらつき
の条件を緩めて解を導きます。

ちなみに、非表示にしているD列に
A列のそれぞれのスタッフが掛け持ちする仕事の数
を計算しています。
C、E列を選択し、右クリックで「再表示」すれば
確認することもできます。

また、計算には時間がかかる為
フリーズしていない事が分かるように
計算の過程が見えるように変えました。

'＜マクロ再再修正版＞
Sub test4()
　On Error GoTo Err
　Dim Work, Staff
　Dim TryStaff As String
　Dim r As Long, c As Long, WorkStaffSum As Long
　Dim StaffNum As Long, WorkNum As Long, RndNum As Long
　Dim MaxWorkStaffNum As Integer, MaxOverlapWork As Integer
　Dim OverlapWork As Integer, MyLastCol As Integer
　Dim CaseNum As Integer, ctNG As Integer, TmpLastCol As Integer
　Dim ctOverlap As Integer, OverlapHosei As Integer
　Dim ct0 As Integer, ct1 As Integer, ct2 As Integer, ct3 As Integer
　Dim ctRetry As Integer, RetryHosei As Integer
　Dim St As Worksheet, MySht As Worksheet, TmpSht As Worksheet
　Dim MyRng As Range, TmpRng As Range, FindStaff As Range, FindWork As Range
　Dim flg As Boolean, MyRngNotFindFlg As Boolean, TmpRngNotFindFlg As Boolean
　Dim MyRowNotFindFlg As Boolean, TmpRowNotFindFlg As Boolean, OverlapFlag As Boolean

　Set MySht = Worksheets("sheet1")　'当番表のシート名

　'前回の当番記録の保存
　For Each St In Worksheets
　　If St.Name = "Tmp" Then
　　　Application.DisplayAlerts = False
　　　St.Delete
　　　Application.DisplayAlerts = True
　　　Exit For
　　End If
　Next
　MySht.Copy After:=MySht
　ActiveSheet.Name = "Tmp"　　'前回表のシート名
　Set TmpSht = Worksheets("Tmp")

　MySht.Activate

　'定数セット
　Work = MySht.Range("B1:C100")
　Staff = MySht.Range("A1:A1000")
　StaffNum = MySht.Range("A65536").End(xlUp).Row - 1
　WorkNum = MySht.Range("B65536").End(xlUp).Row - 1
　MaxWorkStaffNum = WorksheetFunction.Max(MySht.Range("C2:C" & WorkNum + 1))
　WorkStaffSum = WorksheetFunction.Sum(MySht.Range("C2:C" & WorkNum + 1))
　MaxOverlapWork = Int(WorkStaffSum / StaffNum) + 1
　MyLastCol = MaxWorkStaffNum + 4
　With TmpSht.UsedRange
　　TmpLastCol = .Cells(.Cells.Count).Column
　End With
　If MaxWorkStaffNum > StaffNum Then GoTo Err

　Set MyRng = MySht.Range(MySht.Cells(2, "E"), _
　　　　　　　　　　　　　MySht.Cells(WorkNum + 1, MyLastCol))
　Set TmpRng = TmpSht.Range(TmpSht.Cells(2, "E"), _
　　　　　　　　　　　　　　TmpSht.Cells(WorkNum + 1, TmpLastCol))
　ctNG = 0: ctRetry = 0
Retry:
　MySht.Range("D:IV").ClearContents
　Range("E1").Value = "計算中"
　'当番の試行
'　Application.ScreenUpdating = False
　For r = 2 To WorkNum + 1
　　For c = 5 To 4 + Work(r, 2)
　　　flg = False
　　　MyRngNotFindFlg = False: TmpRngNotFindFlg = False
　　　MyRowNotFindFlg = False: TmpRowNotFindFlg = False
　　　OverlapFlag = False
　　　ct0 = 0: ct1 = 0: ct2 = 0: ct3 = 0: ctNG = 0: CaseNum = 0
　　　ctOverlap = 0: OverlapHosei = 0
　　　Set FindStaff = Nothing
　　　Do
　　　　RndNum = Int(Rnd() * StaffNum + 1)　　　'ランダム試行
　　　　TryStaff = Cells(RndNum + 1, "A").Value

　　　　'今回の当番チェック
　　　　Set FindStaff = MySht.Range(MySht.Cells(2, "E"), _
　　　　　　　　　　　　　　　　　　MySht.Cells(r, MyLastCol)).Find(TryStaff)
　　　　If Not FindStaff Is Nothing Then
　　　　　MyRngNotFindFlg = False
　　　　　'今回の同一仕事チェック
　　　　　Set FindStaff = MySht.Range(MySht.Cells(r, "E"), _
　　　　　　　　　　　　　　　　　　MySht.Cells(r, MyLastCol)).Find(TryStaff)
　　　　　If Not FindStaff Is Nothing Then
　　　　　　 MyRowNotFindFlg = False
　　　　　　 Set FindStaff = Nothing
　　　　　Else
　　　　　　 MyRowNotFindFlg = True
　　　　　End If
　　　　Else
　　　　　MyRngNotFindFlg = True
　　　　　MyRowNotFindFlg = True
　　　　End If

　　　　'前回の当番チェック
　　　　Set FindStaff = TmpRng.Find(TryStaff)
　　　　If Not FindStaff Is Nothing Then
　　　　　TmpRngNotFindFlg = False
　　　　　'前回の同一仕事チェック
　　　　　Set FindWork = TmpSht.Range("B:B").Find(MySht.Cells(r, "B").Value)
　　　　　Set FindStaff = TmpSht.Range(TmpSht.Cells(FindWork.Row, "E"), _
　　　　　　　　　　　　　TmpSht.Cells(FindWork.Row, TmpLastCol)).Find(TryStaff)
　　　　　If Not FindStaff Is Nothing Then
　　　　　　TmpRowNotFindFlg = False
　　　　　　Set FindStaff = Nothing
　　　　　Else
　　　　　　TmpRowNotFindFlg = True
　　　　　End If
　　　　Else
　　　　　TmpRngNotFindFlg = True
　　　　　TmpRowNotFindFlg = True
　　　　End If

　　　　'今回の当番数（重複数）のチェック
　　　　OverlapWork = WorksheetFunction.CountIf(MyRng, TryStaff) + 1

　　　　'仕事に対してスタッフが少ないときは、重複許可
　　　　If CaseNum < 3 And Work(r, 2) + c - 4 > StaffNum Then CaseNum = 3
　　　　If CaseNum < 2 And WorksheetFunction.CountA(MyRng) > StaffNum Then CaseNum = 2
　　　　If CaseNum < 1 And WorkStaffSum * 2 > StaffNum Then CaseNum = 1

　　　　'仕事の掛け持ち数を平準化する仕掛け
　　　　If OverlapWork >= MaxOverlapWork + OverlapHosei Then
　　　　　ctOverlap = ctOverlap + 1: OverlapFlag = True
　　　　　If ctOverlap > StaffNum * 3 Then OverlapFlag = False
　　　　Else
　　　　　ctOverlap = 0: OverlapFlag = False
　　　　End If

　　　　If MyRowNotFindFlg = True And _
　　　　　 OverlapFlag = False Then
　　　　　Select Case CaseNum
　　　　　　Case 0 '前回当番をしていない人から選び、今回掛け持ちなし。
　　　　　　　If MyRngNotFindFlg = False Or _
　　　　　　　　　TmpRngNotFindFlg = False Then
　　　　　　　　　ct0 = ct0 + 1
　　　　　　　　　If ct0 > StaffNum * 3 Then CaseNum = 1
　　　　　　　Else
　　　　　　　　　MySht.Cells(r, c) = TryStaff: flg = True
　　　　　　　End If
　　　　　　Case 1　'前回同じ仕事をしていない人から選び、今回掛け持ちなし。
　　　　　　　If MyRngNotFindFlg = False Or _
　　　　　　　　　TmpRowNotFindFlg = False Then
　　　　　　　　　ct1 = ct1 + 1
　　　　　　　　　If ct1 > StaffNum * 3 Then CaseNum = 2
　　　　　　　Else
　　　　　　　　　MySht.Cells(r, c) = TryStaff: flg = True
　　　　　　　End If
　　　　　　Case 2　'前回同じ仕事をしていない人から選び、今回掛け持ちあり。
　　　　　　　If TmpRowNotFindFlg = False Then
　　　　　　　　　ct2 = ct2 + 1
　　　　　　　　　If ct2 > StaffNum * 3 Then CaseNum = 3
　　　　　　　Else
　　　　　　　　　MySht.Cells(r, c) = TryStaff: flg = True
　　　　　　　End If
　　　　　　Case 3 '無条件許可
　　　　　　　MySht.Cells(r, c) = TryStaff: flg = True
　　　　　　Case Else
　　　　　　　MySht.Cells(r, c) = TryStaff: flg = True
　　　　　End Select
　　　 Else
　　　　 ctNG = ctNG + 1
　　　　 If ctNG > StaffNum * 20 Then
　　　　　OverlapHosei = OverlapHosei + 1
　　　　 ElseIf ctNG > StaffNum * 100 Then
　　　　　ctNG = 0
　　　　　GoTo Retry
　　　　 End If
　　　 End If
　　　Loop Until flg = True
　　Next c
　Next r

　Range("E1").Value = "当番表"
　ActiveSheet.UsedRange.EntireColumn.AutoFit
　Columns("D").EntireColumn.Hidden = True
　Application.ScreenUpdating = True

　For r = 2 To StaffNum + 1
　　Cells(r, "D").Value = WorksheetFunction.CountIf(MyRng, Staff(r, 1))
　Next r

　If WorksheetFunction.Max(Range("D2:D" & StaffNum + 1)) _
　　 - WorksheetFunction.Min(Range("D2:D" & StaffNum + 1)) > 1 + RetryHosei Then
　　 If ctRetry > 1 Then RetryHosei = RetryHosei + 1: ctRetry = 0
　　 ctRetry = ctRetry + 1
　　 GoTo Retry
　End If

　Exit Sub

Err:
　Application.ScreenUpdating = True
　MsgBox "error"
End Sub

お礼

何度もすみません。助かります。また、よろしくお願いします。

回答No.9

ka_na_de

ka_na_deです。

再度修正しました。
使い方は以前と同じです。

もし、うまく動作しない場合は
再修正します。

'＜マクロ再修正版＞
Sub test3()
　On Error GoTo Err
　Dim Work, Staff
　Dim TryStaff As String
　Dim r As Long, c As Long, WorkStaffSum As Long
　Dim StaffNum As Long, WorkNum As Long, RndNum As Long
　Dim MaxWorkStaffNum As Integer, MaxOverlapWork As Integer
　Dim OverlapWork As Integer, MyLastCol As Integer, TmpLastCol As Integer
　Dim CaseNum As Integer, ctNG As Integer
　Dim ct0 As Integer, ct1 As Integer, ct2 As Integer, ct3 As Integer
　Dim St As Worksheet, MySht As Worksheet, TmpSht As Worksheet
　Dim MyRng As Range, TmpRng As Range, FindStaff As Range, FindWork As Range
　Dim flg As Boolean, MyRngNotFindFlg As Boolean, TmpRngNotFindFlg As Boolean
　Dim MyRowNotFindFlg As Boolean, TmpRowNotFindFlg As Boolean

　Set MySht = Worksheets("sheet1")　'当番表のシート名

　'前回の当番記録の保存
　For Each St In Worksheets
　　If St.Name = "Tmp" Then
　　　Application.DisplayAlerts = False
　　　St.Delete
　　　Application.DisplayAlerts = True
　　　Exit For
　　End If
　Next
　MySht.Copy After:=MySht
　ActiveSheet.Name = "Tmp"　　'前回表のシート名
　Set TmpSht = Worksheets("Tmp")

　MySht.Activate

　'定数セット
　Work = MySht.Range("B1:C100")
　Staff = MySht.Range("A1:A1000")
　StaffNum = MySht.Range("A65536").End(xlUp).Row - 1
　WorkNum = MySht.Range("B65536").End(xlUp).Row - 1
　MaxWorkStaffNum = WorksheetFunction.Max(MySht.Range("C2:C" & WorkNum + 1))
　WorkStaffSum = WorksheetFunction.Sum(MySht.Range("C2:C" & WorkNum + 1))
　MaxOverlapWork = Int(WorkStaffSum / StaffNum) + 1
　MyLastCol = MaxWorkStaffNum + 4
　With TmpSht.UsedRange
　　TmpLastCol = .Cells(.Cells.Count).Column
　End With
　If MaxWorkStaffNum > StaffNum Then GoTo Err

　Set MyRng = MySht.Range(MySht.Cells(2, "E"), _
　　　　　　　　　　　　　MySht.Cells(WorkNum + 1, MyLastCol))
　Set TmpRng = TmpSht.Range(TmpSht.Cells(2, "E"), _
　　　　　　　　　　　　　　TmpSht.Cells(WorkNum + 1, TmpLastCol))
　MySht.Range("E:IV").ClearContents
　Range("E1").Value = "計算中"

　'当番の試行
　Application.ScreenUpdating = False
　For r = 2 To WorkNum + 1
　　For c = 5 To 4 + Work(r, 2)
　　　flg = False
　　　MyRngNotFindFlg = False: TmpRngNotFindFlg = False
　　　MyRowNotFindFlg = False: TmpRowNotFindFlg = False
　　　ct0 = 0: ct1 = 0: ct2 = 0: ct3 = 0: ctNG = 0: CaseNum = 0
　　　Set FindStaff = Nothing
　　　Do
　　　　RndNum = Int(Rnd() * StaffNum + 1)　　　'ランダム試行
　　　　TryStaff = Cells(RndNum + 1, "A").Value

　　　　'今回の当番チェック
　　　　Set FindStaff = MySht.Range(MySht.Cells(2, "E"), _
　　　　　　　　　　　　　　　　　　MySht.Cells(r, MyLastCol)).Find(TryStaff)
　　　　If Not FindStaff Is Nothing Then
　　　　　MyRngNotFindFlg = False
　　　　　'今回の同一仕事チェック
　　　　　Set FindStaff = MySht.Range(MySht.Cells(r, "E"), _
　　　　　　　　　　　　　　　　　　MySht.Cells(r, MyLastCol)).Find(TryStaff)
　　　　　If Not FindStaff Is Nothing Then
　　　　　　 MyRowNotFindFlg = False
　　　　　　 Set FindStaff = Nothing
　　　　　Else
　　　　　　 MyRowNotFindFlg = True
　　　　　End If
　　　　Else
　　　　　MyRngNotFindFlg = True
　　　　　MyRowNotFindFlg = True
　　　　End If

　　　　'前回の当番チェック
　　　　Set FindStaff = TmpRng.Find(TryStaff)
　　　　If Not FindStaff Is Nothing Then
　　　　　TmpRngNotFindFlg = False
　　　　　'前回の同一仕事チェック
　　　　　Set FindWork = TmpSht.Range("B:B").Find(MySht.Cells(r, "B").Value)
　　　　　Set FindStaff = TmpSht.Range(TmpSht.Cells(FindWork.Row, "E"), _
　　　　　　　　　　　　　TmpSht.Cells(FindWork.Row, TmpLastCol)).Find(TryStaff)
　　　　　If Not FindStaff Is Nothing Then
　　　　　　TmpRowNotFindFlg = False
　　　　　　Set FindStaff = Nothing
　　　　　Else
　　　　　　TmpRowNotFindFlg = True
　　　　　End If
　　　　Else
　　　　　TmpRngNotFindFlg = True
　　　　　TmpRowNotFindFlg = True
　　　　End If

　　　　'今回の当番数（重複数）のチェック
　　　　OverlapWork = WorksheetFunction.CountIf(MyRng, TryStaff) + 1

　　　　'仕事に対してスタッフが少ないときは、前回との重複許可
　　　　If CaseNum = 0 And WorkStaffSum * 2 > StaffNum Then CaseNum = 1

　　　　If MyRowNotFindFlg = True And _
　　　　　 OverlapWork <= MaxOverlapWork Then
　　　　　Select Case CaseNum
　　　　　　Case 0 '前回当番をしていない人から選び、今回掛け持ちなし。
　　　　　　　If MyRngNotFindFlg = False Or _
　　　　　　　　　TmpRngNotFindFlg = False Then
　　　　　　　　　ct0 = ct0 + 1
　　　　　　　　　If ct0 > StaffNum * 5 Then CaseNum = 1
　　　　　　　Else
　　　　　　　　　MySht.Cells(r, c) = TryStaff: flg = True
　　　　　　　End If
　　　　　　Case 1　'前回同じ仕事をしていない人から選び、今回掛け持ちなし。
　　　　　　　If MyRngNotFindFlg = False Or _
　　　　　　　　　TmpRowNotFindFlg = False Then
　　　　　　　　　ct1 = ct1 + 1
　　　　　　　　　If ct1 > StaffNum * 5 Then CaseNum = 2
　　　　　　　Else
　　　　　　　　　MySht.Cells(r, c) = TryStaff: flg = True
　　　　　　　End If
　　　　　　Case 2　'前回同じ仕事をしていない人から選び、今回掛け持ちあり。
　　　　　　　If TmpRowNotFindFlg = False Then
　　　　　　　　　ct2 = ct2 + 1
　　　　　　　　　If ct2 > StaffNum * 5 Then CaseNum = 3
　　　　　　　Else
　　　　　　　　　MySht.Cells(r, c) = TryStaff: flg = True
　　　　　　　End If
　　　　　　Case 3 '無条件許可
　　　　　　　MySht.Cells(r, c) = TryStaff: flg = True
　　　　　　Case Else
　　　　　　　MySht.Cells(r, c) = TryStaff: flg = True
　　　　　End Select
　　　 Else
　　　　 ctNG = ctNG + 1
　　　　 If ctNG > 10000 Then GoTo Err
　　　 End If
　　　Loop Until flg = True
　　Next c
　Next r

　Range("E1").Value = "当番表"
　ActiveSheet.UsedRange.EntireColumn.AutoFit
　Columns("D").EntireColumn.Hidden = True
　Application.ScreenUpdating = False
　Exit Sub

Err:
　MsgBox "error"
End Sub

補足

再度修正していただき、ありがとうございます。来週、早速マクロに挑戦してみます。本当に助かります！

回答No.8

ka_na_de

スタッフ　１２名
仕事　１０件
１件の仕事に対する必要スタッフ２名以上

ですね。

だとすると、仕事は掛け持ちになりますね。

最初から、仕事の掛け持ちを許可し、
前回と同じ仕事にならないようにする
方針で選別することがベストだと思います。

前回のマクロは、もう一回だけ変更しますので、
このまま、締め切らないで下さい。

回答No.7

ka_na_de

かなり修正しました。

＜追加の注意点＞
職員名を数字で連番にしてテストする場合は、
1,2,3,4,5,6,7,8,9,10,11,12,13
とせずに
社員01,社員02,社員03,社員04,社員05・・・・として下さい。
（オートフィルで簡単に複製できます）
理由は検索の都合です。
1で検索すると11や12がヒットしてしまうからなんです。

'＜マクロ修正版＞
Sub test2()
　On Error GoTo Err
　Dim r As Long, c As Long
　Dim StaffNum As Long, WorkNum As Long, RndNum As Long
　Dim MaxWorkStaffNum As Integer
　Dim MyLastCol As Integer, TmpLastCol As Integer
　Dim TryStaff As String
　Dim Work, Staff
　Dim St As Worksheet
　Dim MySht As Worksheet, TmpSht As Worksheet
　Dim MyRng As Range, TmpRng As Range
　Dim FindStaff As Range, FindWork As Range
　Dim flg As Boolean
　Dim MyRngNotFindFlg As Boolean, TmpRngNotFindFlg As Boolean
　Dim MyRowNotFindFlg As Boolean, TmpRowNotFindFlg As Boolean
　Dim CaseNum As Integer
　Dim ct0 As Integer, ct1 As Integer, ct2 As Integer
　Dim ct3 As Integer, ct4 As Integer, ct5 As Integer
　Dim WorkStaffSum As Long

　Set MySht = Worksheets("sheet1")　'当番表のシート名

　'前回の当番記録の保存
　For Each St In Worksheets
　　If St.Name = "Tmp" Then
　　　Application.DisplayAlerts = False
　　　St.Delete
　　　Application.DisplayAlerts = True
　　　Exit For
　　End If
　Next
　MySht.Copy After:=MySht
　ActiveSheet.Name = "Tmp"
　Set TmpSht = Worksheets("Tmp")

　MySht.Activate

　Application.ScreenUpdating = False

　'定数セット
　Work = MySht.Range("B1:C100")
　Staff = MySht.Range("A1:A1000")
　StaffNum = MySht.Range("A65536").End(xlUp).Row - 1
　WorkNum = MySht.Range("B65536").End(xlUp).Row - 1
　MaxWorkStaffNum = WorksheetFunction.Max(MySht.Range("C2:C" & WorkNum + 1))
　WorkStaffSum = WorksheetFunction.Sum(MySht.Range("C2:C" & WorkNum + 1))
　MyLastCol = MaxWorkStaffNum + 4
　With TmpSht.UsedRange
　　TmpLastCol = .Cells(.Cells.Count).Column
　End With
　If MaxWorkStaffNum > StaffNum Then GoTo Err

　Set MyRng = MySht.Range(MySht.Cells(2, "E"), _
　　　　　　　　　　　　　MySht.Cells(WorkNum + 1, MyLastCol))

　Set TmpRng = TmpSht.Range(TmpSht.Cells(2, "E"), _
　　　　　　　　　　　　　　TmpSht.Cells(WorkNum + 1, TmpLastCol))
　MySht.Range("E:IV").ClearContents

　Range("E1").Value = "計算中"

　'当番の試行
　For r = 2 To WorkNum + 1
　　For c = 5 To 4 + Work(r, 2)
　　　flg = False
　　　MyRngNotFindFlg = False
　　　TmpRngNotFindFlg = False
　　　MyRowNotFindFlg = False
　　　TmpRowNotFindFlg = False
　　　ct0 = 0: ct1 = 0: ct2 = 0: ct3 = 0: ct4 = 0: ct5 = 0
　　　If WorkStaffSum > StaffNum Then
　　　　 CaseNum = 3
　　　ElseIf WorkStaffSum * 2 > StaffNum Then
　　　　 CaseNum = 2
　　　Else
　　　　 CaseNum = 0
　　　End If
　　　Do
　　　　RndNum = Int(Rnd() * StaffNum + 1)　　　'ランダム試行
　　　　TryStaff = Cells(RndNum + 1, "A").Value

　　　　'今回の同一仕事チェック
　　　　Set FindStaff = MySht.Range(MySht.Cells(r, "E"), _
　　　　　　　　　　　　　　　　　　MySht.Cells(r, MyLastCol)).Find(TryStaff)
　　　　If Not FindStaff Is Nothing Then
　　　　　Set FindStaff = Nothing
　　　　　MyRowNotFindFlg = False
　　　　Else
　　　　　MyRowNotFindFlg = True
　　　　End If

　　　　'今回の当番チェック
　　　　Set FindStaff = MySht.Range(MySht.Cells(2, "E"), _
　　　　　　　　　　　　　　　　　　MySht.Cells(r, MyLastCol)).Find(TryStaff)
　　　　If Not FindStaff Is Nothing Then
　　　　　Set FindStaff = Nothing
　　　　　MyRngNotFindFlg = False
　　　　Else
　　　　　MyRngNotFindFlg = True
　　　　End If

　　　　'前回の同一仕事チェック
　　　　Set FindWork = TmpSht.Range("B:B").Find(MySht.Cells(r, "B").Value)
　　　　Set FindStaff = TmpSht.Range(TmpSht.Cells(FindWork.Row, "E"), _
　　　　　　　　　　　　TmpSht.Cells(FindWork.Row, TmpLastCol)).Find(TryStaff)
　　　　If Not FindStaff Is Nothing Then
　　　　　Set FindStaff = Nothing
　　　　　TmpRowNotFindFlg = False
　　　　Else
　　　　　TmpRowNotFindFlg = True
　　　　End If

　　　　'前回の当番チェック
　　　　Set FindStaff = TmpRng.Find(TryStaff)
　　　　If Not FindStaff Is Nothing Then
　　　　　Set FindStaff = Nothing
　　　　　TmpRngNotFindFlg = False
　　　　Else
　　　　　TmpRngNotFindFlg = True
　　　　End If

　　　　Select Case CaseNum
　　　　　Case 0 '前回当番をしていない人から選び、今回掛け持ちなし。
　　　　　　If MyRngNotFindFlg = False Or _
　　　　　　　　TmpRngNotFindFlg = False Then
　　　　　　　　ct0 = ct0 + 1
　　　　　　　　If ct0 > StaffNum * 5 Then CaseNum = 1
　　　　　　Else
　　　　　　　　MySht.Cells(r, c) = TryStaff: flg = True
　　　　　　End If

　　　　　Case 1 '前回当番をしていない人から選び、今回掛け持ちあり。
　　　　　　If MyRowNotFindFlg = False Or _
　　　　　　　　TmpRngNotFindFlg = False Then
　　　　　　　　ct1 = ct1 + 1
　　　　　　　　If ct1 > StaffNum * 5 Then CaseNum = 2
　　　　　　Else
　　　　　　　　MySht.Cells(r, c) = TryStaff: flg = True
　　　　　　End If

　　　　　Case 2　'前回同じ仕事をしていない人から選び、今回掛け持ちなし。
　　　　　　If MyRngNotFindFlg = False Or _
　　　　　　　　TmpRowNotFindFlg = False Then
　　　　　　　　　ct2 = ct2 + 1
　　　　　　　　　If ct2 > StaffNum * 5 Then CaseNum = 3
　　　　　　Else
　　　　　　　　　MySht.Cells(r, c) = TryStaff: flg = True
　　　　　　End If

　　　　　Case 3　'前回の当番についてはチェックせず、今回掛け持ちなし。
　　　　　　If MyRngNotFindFlg = False Then
　　　　　　　ct3 = ct3 + 1
　　　　　　　If ct3 > StaffNum * 5 Then CaseNum = 4
　　　　　　Else
　　　　　　　MySht.Cells(r, c) = TryStaff: flg = True
　　　　　　End If

　　　　　Case 4　'今回掛け持ちとなるが、前回の当番と重ならないようにする。
　　　　　　If TmpRowNotFindFlg = False Or MyRowNotFindFlg = False Then
　　　　　　　ct4 = ct4 + 1
　　　　　　　If ct4 > StaffNum * 5 Then CaseNum = 5
　　　　　　Else
　　　　　　　MySht.Cells(r, c) = TryStaff: flg = True
　　　　　　End If

　　　　　Case 5 '今回の同一仕事の掛け持ちのみ不許可
　　　　　　If MyRowNotFindFlg = False Then
　　　　　　　ct5 = ct5 + 1
　　　　　　　If ct5 > StaffNum * 5 Then CaseNum = 6
　　　　　　Else
　　　　　　　MySht.Cells(r, c) = TryStaff: flg = True
　　　　　　End If
　　　　　Case 6 '無条件許可
　　　　　　MySht.Cells(r, c) = TryStaff: flg = True
　　　　　Case Else
　　　　　　MySht.Cells(r, c) = TryStaff: flg = True
　　　　End Select

　　　Loop Until flg = True
　　Next c
　Next r

　Range("E1").Value = "当番表"
　ActiveSheet.UsedRange.EntireColumn.AutoFit
　Columns("D").EntireColumn.Hidden = True
　Application.ScreenUpdating = False
　Exit Sub

Err:
　MsgBox "error"
End Sub

補足

お返事が遅くなりすみません。丁寧な回答どうもありがとうございます。掛け持ちの場合もあります。スタッフは全員で１２名です。マクロにも一度挑戦してみます。

回答No.6

ka_na_de

ka_na_deです。

前回示したマクロですが、
場合によっては、不具合があるようです。
今、修正しています。
完成したら再投稿しますので
まだ、回答を締め切らないで下さい。

回答No.5

ka_na_de

全く意味不明かもしれませんが、
自分の勉強も兼ねて作りました。

＜使い方＞
　１）新規シートのSheet1の
　　　A1セルに、「名前」と入力
　　　A2以下に、社員の名前を列記
　　　（数字の連番でも構いません）
　２）B１セルに、「仕事名」と入力
　　　B2セル以下に、仕事を列記
　３）C1セルに、「人数」と入力
　　　C2セル以下に、仕事の人数を数字で入力
　４）下のシート名「Sheet1」の上で右クリック
　５）「コードの表示」をクリック
　６）左側のプロジェクトエクスプローラーで、
　　VBAProjectのの上で右クリック、「挿入」→「標準モジュール」
　　　（プロジェクトエクスプローラーが表示されていなければ、
　　　　上部の「表示」メニューから選択表示できます。）
　７）右側の空欄に下記のマクロをコピーして貼り付けます。
　８）「ファイル」→「終了してMicrosoft Excel」に戻る。
　９）一旦、適当な名前で保存してください。
　１０）「ツール」→「マクロ」→「マクロ」
　１１）test を選択し「実行」
　１２）E列から左側に当番表ができるはずです。
　　　　D列は非表示ですが気にしないで下さい。

＜説明＞
　２回目からの実行は、前回の当番の内容を[Tmp」という名前の
　シートに複製保存し、できるかぎり前回当番になっていない人
　から優先的に当番を決めます。社員が少ない場合は、仕事の掛
　け持ちも許可しています。しかし、できるかぎり前回との重複
　や掛け持ちをしない方針で計算しています。

＜注意＞
　　　次回このファイルを開くときに、マクロを含んでいるという
　　　警告やセキュリティーレベルを変更するようにといった
　　　警告が出るかもしれません。その場合は、
　　　「ツール」→「マクロ」→「セキュリティー」で
　　　「中」または「低」に変更してください。
　　　「中」にした場合は、その都度マクロを有効にするか聞いて
　　　きますので、信頼できるファイルであれば「有効」にしてく
　　　ださい。「低」は薦めません。

　　全く関係ないソフトのHPに詳しい設定方法が紹介されています
　　ので参考にしてください。
　　　＞​http://e-kyu.com/kyu18/security/security.html​

'＜マクロ＞
Sub test()
　On Error GoTo Err
　Dim r As Long, c As Long
　Dim StaffNum As Long, WorkNum As Long, RndNum As Long
　Dim MaxWorkStaffNum As Integer
　Dim MyLastCol As Integer, TmpLastCol As Integer
　Dim TryStaff As String
　Dim Work, Staff
　Dim St As Worksheet
　Dim MySht As Worksheet, TmpSht As Worksheet
　Dim MyRng As Range, TmpRng As Range
　Dim FindStaff As Range, FindWork As Range
　Dim flg As Boolean
　Dim MyRngNotFindFlg As Boolean, TmpRngNotFindFlg As Boolean
　Dim MyRowNotFindFlg As Boolean, TmpRowNotFindFlg As Boolean
　Dim CaseNum As Integer
　Dim ct0 As Integer, ct1 As Integer, ct2 As Integer
　Dim ct3 As Integer, ct4 As Integer

' Set MySht = ActiveSheet
　Set MySht = Worksheets("sheet1") '当番表のシート名

　'前回の当番記録の保存
　For Each St In Worksheets
　　If St.Name = "Tmp" Then
　　　Application.DisplayAlerts = False
　　　St.Delete
　　　Application.DisplayAlerts = True
　　　Exit For
　　End If
　Next
　MySht.Copy After:=MySht
　ActiveSheet.Name = "Tmp"
　Set TmpSht = Worksheets("Tmp")

　MySht.Activate
　Range("E1").Value = "計算中"

　Application.ScreenUpdating = False

　'定数セット
　Work = MySht.Range("B1:C100")
　Staff = MySht.Range("A1:A1000")
　StaffNum = MySht.Range("A65536").End(xlUp).Row - 1
　WorkNum = MySht.Range("B65536").End(xlUp).Row - 1
　MaxWorkStaffNum = WorksheetFunction.Max(MySht.Range("C2:C" & WorkNum + 1))
　MyLastCol = MaxWorkStaffNum + 4
　With TmpSht.UsedRange
　　TmpLastCol = .Cells(.Cells.Count).Column
　End With
　If MaxWorkStaffNum > StaffNum Then GoTo Err

　Set MyRng = MySht.Range(MySht.Cells(2, "E"), _
　　　　　　　　　　　　　MySht.Cells(WorkNum + 1, MyLastCol))

　Set TmpRng = TmpSht.Range(TmpSht.Cells(2, "E"), _
　　　　　　　　　　　　　　TmpSht.Cells(WorkNum + 1, TmpLastCol))
　MySht.Range("E:IV").ClearContents

　'当番の試行
　For r = 2 To WorkNum + 1
　　For c = 5 To 4 + Work(r, 2)
　　　flg = False
　　　MyRngNotFindFlg = False
　　　TmpRngNotFindFlg = False
　　　MyRowNotFindFlg = False
　　　TmpRowNotFindFlg = False
　　　ct0 = 0: ct1 = 0: ct2 = 0: ct3 = 0: ct4 = 0
　　　CaseNum = 0
　　　Do
　　　　RndNum = Int(Rnd() * StaffNum + 1) 'ランダム試行
　　　　TryStaff = Cells(RndNum + 1, "A").Value

　　　　'今回の同一仕事チェック
　　　　Set FindStaff = MySht.Range(MySht.Cells(r, "E"), _
　　　　　　　　　　　　　　　　　　MySht.Cells(r, MyLastCol)).Find(TryStaff)
　　　　If Not FindStaff Is Nothing Then
　　　　　Set FindStaff = Nothing
　　　　　MyRowNotFindFlg = False
　　　　Else
　　　　　MyRowNotFindFlg = True
　　　　End If

　　　　'今回の当番チェック
　　　　Set FindStaff = MySht.Range(MySht.Cells(2, "E"), _
　　　　　　　　　　　　　　　　　　MySht.Cells(r, MyLastCol)).Find(TryStaff)
　　　　If Not FindStaff Is Nothing Then
　　　　　Set FindStaff = Nothing
　　　　　MyRngNotFindFlg = False
　　　　Else
　　　　　MyRngNotFindFlg = True
　　　　End If

　　　　'前回の同一仕事チェック
　　　　Set FindWork = TmpSht.Range("B:B").Find(MySht.Cells(r, "B").Value)
　　　　Set FindStaff = TmpSht.Range(TmpSht.Cells(FindWork.Row, "E"), _
　　　　　　　　　　　　TmpSht.Cells(FindWork.Row, MyLastCol)).Find(TryStaff)
　　　　If Not FindStaff Is Nothing Then
　　　　　Set FindStaff = Nothing
　　　　　TmpRowNotFindFlg = False
　　　　Else
　　　　　TmpRowNotFindFlg = True
　　　　End If

　　　　'前回の当番チェック
　　　　Set FindStaff = TmpRng.Find(TryStaff)
　　　　If Not FindStaff Is Nothing Then
　　　　　Set FindStaff = Nothing
　　　　　TmpRngNotFindFlg = False
　　　　Else
　　　　　TmpRngNotFindFlg = True
　　　　End If

　　　　Select Case CaseNum
　　　　　Case 0 '前回当番をしていない人から選び、今回掛け持ちなし。
　　　　　　If MyRngNotFindFlg = False Or _
　　　　　　　　TmpRngNotFindFlg = False Then
　　　　　　　　ct0 = ct0 + 1
　　　　　　　　If ct0 > WorkNum * 30 Then CaseNum = 1
　　　　　　Else
　　　　　　　　MySht.Cells(r, c) = TryStaff: flg = True
　　　　　　End If

　　　　　Case 1 '前回同じ仕事をしていない人から選び、今回掛け持ちなし。
　　　　　　If MyRngNotFindFlg = False Or _
　　　　　　　　TmpRowNotFindFlg = False Then
　　　　　　　　　ct1 = ct1 + 1
　　　　　　　　　If ct1 > WorkNum * 30 Then CaseNum = 2
　　　　　　Else
　　　　　　　　　MySht.Cells(r, c) = TryStaff: flg = True
　　　　　　End If

　　　　　Case 2 '前回の当番についてはチェックせず、今回掛け持ちなし。
　　　　　　If MyRngNotFindFlg = False Then
　　　　　　　ct2 = ct2 + 1
　　　　　　　If ct2 > WorkNum * 30 Then CaseNum = 3
　　　　　　Else
　　　　　　　MySht.Cells(r, c) = TryStaff: flg = True
　　　　　　End If

　　　　　Case 3 '今回掛け持ちとなるが、前回の当番と重ならないようにする。
　　　　　　If TmpRowNotFindFlg = False Then
　　　　　　　ct3 = ct3 + 1
　　　　　　　If ct3 > WorkNum * 30 Then CaseNum = 4
　　　　　　Else
　　　　　　　MySht.Cells(r, c) = TryStaff: flg = True
　　　　　　End If

　　　　　Case 4 '今回の同一仕事の掛け持ちは不許可
　　　　　　If MyRowNotFindFlg = False Then
　　　　　　　ct4 = ct4 + 1
　　　　　　　If ct4 > WorkNum * 30 Then CaseNum = 5
　　　　　　Else
　　　　　　　MySht.Cells(r, c) = TryStaff: flg = True
　　　　　　End If
　　　　　Case 5 '無条件許可
　　　　　　MySht.Cells(r, c) = TryStaff: flg = True
　　　　　Case Else
　　　　　　MySht.Cells(r, c) = TryStaff: flg = True
　　　　End Select
　　　Loop Until flg = True
　　Next c
　Next r

　Range("E1").Value = "当番表"
　ActiveSheet.UsedRange.EntireColumn.AutoFit
　Columns("D").EntireColumn.Hidden = True
　Application.ScreenUpdating = False 　
　Exit Sub

Err:
　MsgBox "error"
End Sub

回答No.4

ka_na_de

＃３です。
もう一つ質問です。

１）社員の数はどのくらいですか？
　　当番の数と社員の数の関係が知りたいです。
　　　　　　　　↓
２）社員の数より当番の数が多いと
　　同じ社員が同じ月に複数の当番を掛け持ちすると思いますが、
　　その可能性はありますか？

いままでの補足説明だと、
　２名～１２名必要な当番が１０件あるのですね。
　当番が２０名～１２０名となりますが、
　社員の規模はどの位なのか知りたいです。
　微妙な線であれば、掛け持ちも考慮して計算しなければ
　なりませんね。

回答No.3

ka_na_de

問題は解決しましたか？

質問の件ですが、もうちょっと補足説明していただけると、
具体的な回答が出るかもしれませんよ。

１）仕事は何件くらいですか？
２）何人くらいの中から役割当番を決めますか？
３）一つの仕事に対する役割当番は一人でいいのですか？
４）前回当番にならなかった人から優先的に割り振るのですか？
５）同じ当番を続けて行わないようにするのですか？

特に４）５）を求めると、マクロになるかな～と思います。

補足

先の回答で今日、当番表を作成してみました。同じ人が当番連続になる場合（二人だけでする場合）が出てしまいました。補足説明が足りなくてすみませんでした。
１）役割当番は１０件です。（郵便当番など）
２）仕事の内容により２名～１２名と人数が違います。
３）一つの仕事に対する役割当番は二人以上です。
４）前回、当番にならなかった人から優先的に割り振りしたいです。
５）同じ当番を続けて行わないようにしたいです。
よろしくお願いします。

回答No.2

imogasi

（１）作業列に乱数を発生させる
９０人ぐらい以下で、２桁なら=INT(RAND()*90+10)と入れて、人数分発生させる。
同じ数が発生する可能性はあるが、並べ替えればどちらかが先に行くから、差し支えない。
４桁の乱数を発生させると同じ数は出る頻度は下げられるが。
（２）乱数列で、自分自身を自分のセルに値複写して、値化して式を消したほうが良かろう。
（３）元に戻すためには、基本の連番列などが、当初設定必要か。
（４）現実には、人数組み合わせを繰り回していくケースが多いのではないですか。１人選出なら良いが、グループだと役割分担などあり機械的にはむつかしいのでは。

補足

回答どうもありがとうございます。回答の（４）にあるように、現実にはグループだと機械的に難しいと思いました。私の補足も足りなくてすみませんでした。

回答No.1

Bubuca

こんにちは

乱数発生を使う方法はどうでしょうか。
作業列を一列挿入して、=rand()と入れて、下までコピーします。
あとはこの列を基準にして表全体を昇順なり降順なりでソートします。
再計算の度に乱数も再発生するので少々うっとうしいかもしれませんが、
例えば=RAND()*(100-1)+1として、小数点以下を表示しないように桁数を設定すれば１～１００の乱数ができるので扱いやすいかもしれません。
見かけは同じ数字が表れることもありますが、小数点以下で違う数字になっています。
別な列に連番を振っておいて、こちらでソートすれば元の状態に戻れるようにしておくのもいいかもしれません。

補足

早速、回答いただきありがとうございました。関数を普段使用しなくて勉強になりました。今日、さっそく使ってみました。ただ、私の補足が足りなくて、２名担当だと同じ人が毎月同じ仕事になってしまいました。