excellで出来ないでしょうか

質問

私どもはある組織の宿日直を総員７名でやっております、宿直も日直も2名で出勤します。
人員の配置は毎月籤を引きながらやっておりますがどうしても毎月同じ人同士の組み合わせになることが多くあります、そこで何とかEXCELLを使い皆でランダムにやる方法はないかと考えております、私も考えてみたのですがなかなかよい方法（工夫）が出来ません何方かお知恵を拝借したいと思い質問を致します。

平日（P.M.5:30~次の日のA.M.8:30まで）の宿直と土・日・祝祭日の日直を（A.M.8:30~P.M.5:30）７名で行っております（年間365日休めません）、人員の配置方法としての禁止事項は以下の通りです。
１）宿直の次に日直は出来ません（連続での出勤になりますので）。
２）宿直が連続で出来ません（出来ないことはありませんが出来ればしない方がgood！）。
３）7名の人員を宿直と日直は常にランダムで行いたい、つまり毎回出来れば同じ組み合わせ　　でやりたくない。
４）年間で考えたいと思います。（月毎ですと月末と月初の組み合わせが上記の禁止事項になることがある）
以上の条件でEXCELLに拘りませんので方法がないものかと考えております、宜しくお願い致します。（人員はA・B・・・・Ｆ・Gで表現します）

回答No.10

tom04

↓から続きです。

'★ここから後半
If Cells(i, "D") = "" Then
Do Until myFlg = True
If myRow = endRow Then
myRow = 1
End If
myRow = myRow + 1
str1 = Left(Cells(myRow, "I"), InStr(Cells(myRow, "I"), ",") - 1)
str2 = Mid(Cells(myRow, "I"), InStr(Cells(myRow, "I"), ",") + 1, 10)
Set c = myRng1.Find(what:=str1, LookIn:=xlValues, lookat:=xlPart)
Set r = myRng1.Find(what:=str2, LookIn:=xlValues, lookat:=xlPart)
If c Is Nothing And r Is Nothing Then
myFlg = True
Else
Cells(Rows.Count, "P").End(xlUp).Offset(1) = Cells(myRow, "I")
End If
Loop
Cells(i, "D") = Cells(myRow, "I")
myFlg = False
End If

If WorksheetFunction.CountA(Range("P:P")) > 0 Then
For k = 2 To Cells(Rows.Count, "P").End(xlUp).Row
If Cells(k, "P") <> "" Then
str1 = Left(Cells(k, "P"), InStr(Cells(k, "P"), ",") - 1)
str2 = Mid(Cells(k, "P"), InStr(Cells(k, "P"), ",") + 1, 10)
Set c = myRng2.Find(what:=str1, LookIn:=xlValues, lookat:=xlPart)
Set r = myRng2.Find(what:=str2, LookIn:=xlValues, lookat:=xlPart)
If c Is Nothing And r Is Nothing Then
myFlg = True
Exit For
End If
End If
Next k
If myFlg = True Then
Cells(i, "E") = Cells(k, "P")
Cells(k, "P").ClearContents
myFlg = False
End If
End If

If Cells(i, "E") = "" Then
Do Until myFlg = True
If myRow = endRow Then
myRow = 1
End If
myRow = myRow + 1
str1 = Left(Cells(myRow, "I"), InStr(Cells(myRow, "I"), ",") - 1)
str2 = Mid(Cells(myRow, "I"), InStr(Cells(myRow, "I"), ",") + 1, 10)
Set c = myRng2.Find(what:=str1, LookIn:=xlValues, lookat:=xlPart)
Set r = myRng2.Find(what:=str2, LookIn:=xlValues, lookat:=xlPart)
If c Is Nothing And r Is Nothing Then
myFlg = True
Else
Cells(Rows.Count, "P").End(xlUp).Offset(1) = Cells(myRow, "I")
End If
Loop
Cells(i, "E") = Cells(myRow, "I")
myFlg = False
End If
Next i
Range("P:P").ClearContents
End Sub

※　とりあえずA～Gのメンバーの年間日数はある程度バランスが取れると思います。m(_ _)m

回答No.9

tom04

No.3・5です。

もう一度考えてみました。
前回のコードは消去して↓のコードにしてみてください。
（今回もシートモジュールです）
尚、P列も予備の組合せ（続けて勤務できない組合せ）用として使用していますので、
P列は使っていない状態にしてください。
今回も必要なのは前回の画像通りの配置にしておいてください。

必要なのはA～C列とG列のデータのみです。

尚、一度に投稿すると制限文字数を超えそうなので
2回に分けて投稿します。

まず前半部分です

Sub 振り分け3()
Dim i As Long, k As Long, cnt As Long, myRow As Long, lastRow As Long, endRow As Long
Dim myRng1 As Range, myRng2 As Range, myFlg As Boolean
Dim str1 As String, str2 As String, c As Range, r As Range

'▼組合せ順
endRow = Cells(Rows.Count, "I").End(xlUp).Row
If endRow > 1 Then
Range(Cells(2, "I"), Cells(endRow, "J")).ClearContents
End If
cnt = 1
For i = 2 To Cells(Rows.Count, "G").End(xlUp).Row
For k = i + 1 To Cells(Rows.Count, "G").End(xlUp).Row
cnt = cnt + 1
Cells(cnt, "I") = Cells(i, "G") & "," & Cells(k, "G")
Next k
Next i
endRow = Cells(Rows.Count, "I").End(xlUp).Row
With Range(Cells(2, "J"), Cells(endRow, "J"))
.Formula = "=RAND()"
.Value = .Value
End With
Range(Cells(1, "I"), Cells(endRow, "J")).Sort key1:=Range("J1"), order1:=xlAscending, Header:=xlYes
'▲

'▼D・E列表示
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
If lastRow > 1 Then
Range(Cells(2, "D"), Cells(lastRow, "E")).ClearContents
End If
Range(Cells(2, "L"), Cells(lastRow, "M")).Formula = "=LEFT(D2,1)"
Range(Cells(2, "N"), Cells(lastRow, "O")).Formula = "=RIGHT(D2,1)"
Range(Cells(2, "H"), Cells(Cells(Rows.Count, "G").End(xlUp).Row, "H")).Formula = "=COUNTIF(L:O,G2)"

myRow = 1
For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
Set myRng1 = Cells(i - 1, "E")
Set myRng2 = Union(Cells(i - 1, "E"), Cells(i, "D"))

If WorksheetFunction.CountA(Range("P:P")) > 0 Then
For k = 2 To Cells(Rows.Count, "P").End(xlUp).Row
If Cells(k, "P") <> "" Then
str1 = Left(Cells(k, "P"), InStr(Cells(k, "P"), ",") - 1)
str2 = Mid(Cells(k, "P"), InStr(Cells(k, "P"), ",") + 1, 10)
Set c = myRng1.Find(what:=str1, LookIn:=xlValues, lookat:=xlPart)
Set r = myRng1.Find(what:=str2, LookIn:=xlValues, lookat:=xlPart)
If c Is Nothing And r Is Nothing Then
myFlg = True
Exit For
End If
End If
Next k
If myFlg = True Then
Cells(i, "D") = Cells(k, "P")
Cells(k, "P").ClearContents
myFlg = False
End If
End If
'★ここまでが前半

回答No.8

weboner

リンクが違っていたようなのでもう一度

https://drive.google.com/file/d/0Byv1RH48tHeaWDVvWUtIYVZJRVE/view?usp=sharing

何度もすみません

回答No.7

weboner

マクロが正常動作しなかったので、修正版をUPしました

https://drive.google.com/file/d/0Byv1RH48tHeaSUNsRkVueVYwQkU/view?usp=sharing

ダウンロードして試して下さい

回答No.6

weboner

No4です

不可能だけで終わるのも何なので、一応手動で制作するシートを作ってみました

https://drive.google.com/file/d/0Byv1RH48tHeaV0UwTmRldVUzdG8/view?usp=sharing

メインシートで選択可能なパターン一覧から【選択】をクリックして【決定】ボタンをクリックしていくだけで勤務表が追加されていきます
【取消】で一日分削除されます

パターン一覧でセルの塗りつぶし数が多いものを選択していくだけで、勤務日数／休日が平均的に割りつけされます

条件として
過去30日に同じパターンがない
過去一週間で同じペアでの日直がない
過去一週間で同じペアでの宿直がない
日直→日直の勤務がない
宿直→宿直の勤務がない
連休がない

※計算Sheetは作業用のシートなので編集しないで下さい（一応PW無しで保護してあります）

勤務表作成の参考にして下さい

回答No.5

tom04

No.3です。

もう一度考えてみました。
結論としてバランスよく！は難しいと思います。

（1）～（3）重視で考えてみました。
極力同じメンバー同士の組み合わせにならないようにしてみましたが
そうすると年間出勤日数のばらつきが出てきます。

↓の画像のようにA～C列は前回同様の様式にしておいてください。
今回はD・E列に表示させてみました。

画像では色々表示されていますが、必要なのはA～C列と「メンバー表」のG列だけです。

I列はG列メンバーのすべての組合せを重複なしに表示させています。
J列はI列をランダムに並び替えるための列です。
L～O列は各行（その日）の出勤メンバーです。
H列はG列の人が年間何日の出勤か？を計算しています。
（これらはマクロで処理しています）

前回同様シートモジュールにしてみてください。

Sub 振り分け2()
Dim i As Long, k As Long, cnt As Long, myRow As Long, lastRow As Long, endRow As Long
Dim myRng1 As Range, myRng2 As Range, myFlg As Boolean
Dim str1 As String, str2 As String, c As Range, r As Range

'▼組合せ順
endRow = Cells(Rows.Count, "I").End(xlUp).Row
If endRow > 1 Then
Range(Cells(2, "I"), Cells(endRow, "J")).ClearContents
End If
cnt = 1
For i = 2 To Cells(Rows.Count, "G").End(xlUp).Row
For k = i + 1 To Cells(Rows.Count, "G").End(xlUp).Row
cnt = cnt + 1
Cells(cnt, "I") = Cells(i, "G") & "," & Cells(k, "G")
Next k
Next i
endRow = Cells(Rows.Count, "I").End(xlUp).Row
With Range(Cells(2, "J"), Cells(endRow, "J"))
.Formula = "=RAND()"
.Value = .Value
End With
Range(Cells(1, "I"), Cells(endRow, "J")).Sort key1:=Range("J1"), order1:=xlAscending, Header:=xlYes
'▲

'▼D・E列表示
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
If lastRow > 1 Then
Range(Cells(2, "D"), Cells(lastRow, "E")).ClearContents
End If
Range(Cells(2, "L"), Cells(lastRow, "M")).Formula = "=LEFT(D2,1)"
Range(Cells(2, "N"), Cells(lastRow, "O")).Formula = "=RIGHT(D2,1)"
Range(Cells(2, "H"), Cells(Cells(Rows.Count, "G").End(xlUp).Row, "H")).Formula = "=COUNTIF(L:O,G2)"
myRow = 1
For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
Set myRng1 = Cells(i - 1, "E")
Set myRng2 = Union(Cells(i - 1, "E"), Cells(i, "D"))

Do Until myFlg = True
If myRow = endRow Then
myRow = 1
End If
myRow = myRow + 1
str1 = Left(Cells(myRow, "I"), InStr(Cells(myRow, "I"), ",") - 1)
str2 = Mid(Cells(myRow, "I"), InStr(Cells(myRow, "I"), ",") + 1, 10)
Set c = myRng1.Find(what:=str1, LookIn:=xlValues, lookat:=xlPart)
Set r = myRng1.Find(what:=str2, LookIn:=xlValues, lookat:=xlPart)
If c Is Nothing And r Is Nothing Then
myFlg = True
End If
Loop
Cells(i, "D") = Cells(myRow, "I")
myFlg = False

Do Until myFlg = True
If myRow = endRow Then
myRow = 1
End If
myRow = myRow + 1
str1 = Left(Cells(myRow, "I"), InStr(Cells(myRow, "I"), ",") - 1)
str2 = Mid(Cells(myRow, "I"), InStr(Cells(myRow, "I"), ",") + 1, 10)
Set c = myRng2.Find(what:=str1, LookIn:=xlValues, lookat:=xlPart)
Set r = myRng2.Find(what:=str2, LookIn:=xlValues, lookat:=xlPart)
If c Is Nothing And r Is Nothing Then
myFlg = True
End If
Loop
Cells(i, "E") = Cells(myRow, "I")
myFlg = False
Next i
End Sub

※　何度かマクロを実行して、バランスよく配置できないか？やってみましたが
日数にばらつきがどうしても出てきます。
実際に上記マクロを何度も実行してみてください。

※　パートナーの組合せが同じであれば勤労日数はバランスよく配置できますが、
いずれにしても
（1）（2）の条件と（3）の条件がネックになると思います。

※　何度も何度もマクロを実行してみてください。
運が良ければ勤労日数がある程度均等になるかもしれません。

お手上げです。m(_ _)m

回答No.4

weboner

結論から言うと
指定された条件での勤務表作成は、非常に困難（無理）

確かに7人から2人を抜き取る組み合わせだけ考えると
21通り：Excel計算式だと=COMBIN(7,2)

例えば日直のみの勤務表なら21通りをローテすればいいのですが
これに宿直／休日の組み合わせまで加味すると話が複雑に

7人中勤務4人（日直＋宿直）ということは休みが3人
7人から休みの3人を抜き出した場合の組み合わせは
35通り
例えばEFGの3人が休みの場合勤務割りは

日直 宿直
AB CD
AC BD
AD BC
BC AD
BD AC
CD AB
↑の6通り

全体の組み合わせは
35*6＝210通りになります

単純に210通りの組み合わせを考えた場合総当りで勤務表を作成するとその数は
210!= 1.0582362029223656378427428424335e+398

最初に一日を任意で指定た場合でも
209!= 5.039220013916026846870204011588e+395

総当りで条件に合う勤務表作成は量子コンピュータでも使わないと無理
（実際は勤務条件があるので全部計算する必要は無いのですが）

ただ勤務条件を加味した場合であっても

日直 宿直
AB CD
の翌日はCDの二人は休み、日直の何方かが休み、なので勤務の組み合わせは
AEFGかBEFGの2パターン*3通り（前日日直者を宿直に配置した場合）
6通りの勤務パターンから過去6日前までの勤務状態から同じ組み合わせの含まないパターンを選択
選択した組み合わせを210通りの一覧から削除

以下同じことの繰り返しで一見可能なようですが
・前日のに直者のどちらを休みにするか
・6通りの勤務パターンから選択可能なものが複数存在する場合どれを選択するか
↑
この選択を誤ると10日目辺りで手詰まりになります

非常に難解なパズルですｗ

エクセルのマクロで組むには相当の数学力が必要と思います

勤務210通り全パターン：Excelに貼り付けて勤務割作成に利用して下さい
日直 宿直 休日
AB CD EFG
AC BD EFG
AD BC EFG
BC AD EFG
BD AC EFG
CD AB EFG
AB CE DFG
AC BE DFG
AE BC DFG
BC AE DFG
BE AC DFG
CE AB DFG
AB CF DEG
AC BF DEG
AF BC DEG
BC AF DEG
BF AC DEG
CF AB DEG
AB CG DEF
AC BG DEF
AG BC DEF
BC AG DEF
BG AC DEF
CG AB DEF
AB DE CFG
AD BE CFG
AE BD CFG
BD AE CFG
BE AD CFG
DE AB CFG
AB DF CEG
AD BF CEG
AF BD CEG
BD AF CEG
BF AD CEG
DF AB CEG
AB DG CEF
AD BG CEF
AG BD CEF
BD AG CEF
BG AD CEF
DG AB CEF
AB EF CDG
AE BF CDG
AF BE CDG
BE AF CDG
BF AE CDG
EF AB CDG
AB EG CDF
AE BG CDF
AG BE CDF
BE AG CDF
BG AE CDF
EG AB CDF
AB FG CDE
AF BG CDE
AG BF CDE
BF AG CDE
BG AF CDE
FG AB CDE
AC DE BFG
AD CE BFG
AE CD BFG
CD AE BFG
CE AD BFG
DE AC BFG
AC DF BEG
AD CF BEG
AF CD BEG
CD AF BEG
CF AD BEG
DF AC BEG
AC DG BEF
AD CG BEF
AG CD BEF
CD AG BEF
CG AD BEF
DG AC BEF
AC EF BDG
AE CF BDG
AF CE BDG
CE AF BDG
CF AE BDG
EF AC BDG
AC EG BDF
AE CG BDF
AG CE BDF
CE AG BDF
CG AE BDF
EG AC BDF
AC FG BDE
AF CG BDE
AG CF BDE
CF AG BDE
CG AF BDE
FG AC BDE
AD EF BCG
AE DF BCG
AF DE BCG
DE AF BCG
DF AE BCG
EF AD BCG
AD EG BCF
AE DG BCF
AG DE BCF
DE AG BCF
DG AE BCF
EG AD BCF
AD FG BCE
AF DG BCE
AG DF BCE
DF AG BCE
DG AF BCE
FG AD BCE
AE FG BCD
AF EG BCD
AG EF BCD
EF AG BCD
EG AF BCD
FG AE BCD
BC DE AFG
BD CE AFG
BE CD AFG
CD BE AFG
CE BD AFG
DE BC AFG
BC DF AEG
BD CF AEG
BF CD AEG
CD BF AEG
CF BD AEG
DF BC AEG
BC DG AEF
BD CG AEF
BG CD AEF
CD BG AEF
CG BD AEF
DG BC AEF
BC EF ADG
BE CF ADG
BF CE ADG
CE BF ADG
CF BE ADG
EF BC ADG
BC EG ADF
BE CG ADF
BG CE ADF
CE BG ADF
CG BE ADF
EG BC ADF
BC FG ADE
BF CG ADE
BG CF ADE
CF BG ADE
CG BF ADE
FG BC ADE
BD EF ACG
BE DF ACG
BF DE ACG
DE BF ACG
DF BE ACG
EF BD ACG
BD EG ACF
BE DG ACF
BG DE ACF
DE BG ACF
DG BE ACF
EG BD ACF
BD FG ACE
BF DG ACE
BG DF ACE
DF BG ACE
DG BF ACE
FG BD ACE
BE FG ACD
BF EG ACD
BG EF ACD
EF BG ACD
EG BF ACD
FG BE ACD
CD EF ABG
CE DF ABG
CF DE ABG
DE CF ABG
DF CE ABG
EF CD ABG
CD EG ABF
CE DG ABF
CG DE ABF
DE CG ABF
DG CE ABF
EG CD ABF
CD FG ABE
CF DG ABE
CG DF ABE
DF CG ABE
DG CF ABE
FG CD ABE
CE FG ABD
CF EG ABD
CG EF ABD
EF CG ABD
EG CF ABD
FG CE ABD
DE FG ABC
DF EG ABC
DG EF ABC
EF DG ABC
EG DF ABC
FG DE ABC

回答No.3

tom04

こんばんは！

VBAになりますが、一案です。
連続2日勤続をしないようにしてみました。
↓の画像でSheet2に祝日データを作成しておきます。

そして、Sheet1のA2セルに
2015/1/1　と入力　→　「フィル」（メニューバーの右上のΣマークの下にある下向き矢印のアイコン）の右側▼をクリック
→　連続データの作成　→　「列」を選択　→　停止値に　2015/12/31　と入力しOK

B2セルに
=TEXT(A2,"aaa")
という数式を入れ、条件付き書式　→　新しいルール　→　数式を使用して・・・　→　数式欄に
=C2="日直"
という数式を入れ　→　書式　→　塗りつぶしから「赤」を選択しOK
B2セルのフィルハンドルでダブルクリック（この段階では「赤」は表示されません）

C2セルに
=IF(OR(WEEKDAY(A2,2)>5,COUNTIF(Sheet2!B:C,A2)),"日直","宿直")
という数式を入れ、C2セルのフィルハンドルでダブルクリック

そして、I列1行目から「人員」を羅列しておきます。

これで下準備は完了です。

次に画面左下の「Sheet1」のSheet見出し上で右クリック　→　コードの表示　→　VBE画面のカーソルが点滅しているところに
↓のコードをコピー＆ペースト　→　Excel画面に戻りマクロを実行してみてください。
（Alt＋F8キー　→　マクロ　→　マクロ実行です）

Sub 振り分け() 'この行から
Dim i As Long, myRow1 As Long, myRow2 As Long, myCol As Long
Dim c As Range, r As Range, myFlg As Boolean

myRow1 = 0
myRow2 = Cells(Rows.Count, "I").End(xlUp).Row + 1
For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
If Cells(i, "C") = "日直" Then
myCol = 4
Else
myCol = 6
End If
Do Until myFlg = True
If myRow1 = Cells(Rows.Count, "I").End(xlUp).Row Then
myRow1 = 0
End If
myRow1 = myRow1 + 1
Set c = Cells(i - 1, "D").Resize(, 4).Find(what:=Cells(myRow1, "I"), LookIn:=xlValues, lookat:=xlWhole)
If c Is Nothing Then
myFlg = True
End If
Loop
Cells(i, myCol) = Cells(myRow1, "I")
myFlg = False
Do Until myFlg = True
If myRow2 = 1 Then
myRow2 = Cells(Rows.Count, "I").End(xlUp).Row + 1
End If
myRow2 = myRow2 - 1
Set r = Cells(i - 1, "D").Resize(2, 4).Find(what:=Cells(myRow2, "I"), LookIn:=xlValues, lookat:=xlWhole)
If r Is Nothing Then
myFlg = True
End If
Loop
Cells(i, myCol + 1) = Cells(myRow2, "I")
myFlg = False
Next i
End Sub 'この行まで

※　とりあえず連続勤務はないようにし、全員がほぼ同じ勤務日数になると思います。
※　日直・宿直のバランスや1週当たりの勤務日数などは無視しています。

こんな感じではどうでしょうか？m(_ _)m

お礼

早速のご回答ありがとう御座います、だいぶ考えて頂いたようで恐縮しております。小生の説明不足で申し訳ありません。私も考えてみます。

補足

スミマセン私の説明が足りなかったようです、土・日・祝祭日の日直の後も引き続き別の二名が宿直をします。それもあり
禁止事項にも以下の用にしました。
１）宿直の次に日直は出来ません（連続での出勤になりますので）。

そうなるとマクロもだいぶ変わってきますでしょうか？？

回答No.2

bunjii

>私どもはある組織の宿日直を総員７名でやっております、宿直も日直も2名で出勤します。
>7名の人員を宿直と日直は常にランダムで行いたい、つまり毎回出来れば同じ組み合わせでやりたくない。
7名の中から2名を選ぶ組み合わせは21種しかありませんので22回目は同じ組み合わせになります。
21本の籤を用意して21日毎に割り振ることになるでしょう。
貼付画像はA～G（7名相当）の中で2種（2名相当）の組み合わせを表にしたものです。

禁則になるときは21日の中で交換すれば年間での回数は均等に近づきますが完全な均等にはなりません。
同じ組み合わせは年間で約17回になります。
Excelで籤引きの代わりをするにはRAND関数、RANDBETWEEN関数（Excel 2007以降）等で乱数を発生させれば良いでしょう。

お礼

早速のご回答ありがとう御座いました、仰ることは理解できるので何とかやってみようと思います。

回答No.1

kgrjy

１か月単位の変形労働時間制ですね。１年通しての累算が公平ににするのはわかるのですが、あくまでも１か月以内の暦日数から求まる労働時間の総枠（暦日数×40÷７）に抵触することは許されません（違法）。

で、７名でランダムに動かしてるのに、同じ人の組み合わせが固定的にできるとのこと。希望を受け付けても受付ずでも、ランダムも規則性をもたせれば固定化しないんですがね。

あと、日勤夜勤の入り乱れの勤務予定表は月で回さないで、４週（２８日）で回されることです（４週ごとに勤務予定を立て年１３回勤務予定を立てることになる、暦月とずれようが、休日時間外労働は各日ごとに把握できるので、月給払いに影響しない）。翌勤務予定表との切れ目は、もちろん現勤務予定表の末と睨み合わせてつるのは当然のことです。

エクセルでは、日勤夜勤を立ててない日は、色付け条件書式にて目立つようにできます。あるいは作業列（横に流すなら行）でcountif関数で確認、月間総労働時間の集計でしょう。それでモレ人数過不足がないか、チェックします。夜勤を入力してその明け休みの自動記入するにはマクロでしょうかね。解決にちょっと遠くてすみません。

お礼

早速のご回答ありがとう御座います、何とか工夫してやって見ます。