ここから本文です

エクセルにて下記内容の当番表を関数、もしくはvbaを駆使して簡単に作成できないで...

tak********さん

2020/6/516:35:48

エクセルにて下記内容の当番表を関数、もしくはvbaを駆使して簡単に作成できないでしょうか。分かる方がいらっしゃればご教授お願いします。

☆2つのグループから順番にペア組む当番表を作りたい

条件1.場所のローテーションは固定
条件2.前回と同じ場所を担当することは不可とする
条件3.組み合わせ不可のペアが存在する(あ→さ、い→な・ま、え→な、ら)
条件4.当番回数の誤差は極力抑えたい

参考図もご確認ください。

現在、一つ一つ表に起こしながら組み合わせを作っており、何かいい方法があれば助かります。

Or myerr,myary2,mystr2,If myerr,Or gxary,条件,ローテーション

閲覧数:
71
回答数:
1
お礼:
100枚

違反報告

ベストアンサーに選ばれた回答

gla********さん

2020/6/817:08:34

作るのに3日かかりました。現役時代を思い出しながら作りました。現役の時、この処理ができていたら、と思うと残念です。でも、並べるところまでは昔の処理が役立ちました。他の方法もあると思いますが、手作業の手順をコードにしてみました。
1.仕様
B列:担当者1「あいうえいあえう」の繰り返しで固定(25行目まで)
C列:担当者2「グループY」が入るところ(自動処理したものを入れます)
D列:場所「AB」の繰り返しで固定(25行目まで)
F列:グループX「あいうえ」(固定なので処理には使わない)
G列:グループY「かさたなはまやらわをん」で重複しない名前が11人
2.使い方
①MyArrange処理:グループYのメンバーを、相性をチェックしながらランダムな並びで作ります。
1回あたり20,000回処理し、結果が出ないときは「やり直し」のメッセージがでますので、マクロ処理を繰り返してください。結果が出ると「適切な並びができました」とメッセージがでます。[OK]で担当者2に自動記入されます。1回で終わることもあるし、12回処理することもあります。15回以内には処理が終わるようです。(20,000回を外し、結果が出るまで待っても結果が出せないため、このような方法になりました。)
②①が終わったら、1回目の出来た並びをそのままに、2回目のMyArrange処理を実行します。方法は①と同じです。結果は、1回目の下に作成されます。
③OverlapCheck処理:1,2回目の並び処理ができたら、実行します。この処理は、ABの組合せがうまくいかなかったところを修正処理するものです。修正処理がうまくいかない場合は、そのセルを赤く塗りつぶします。そして、「再度 [MyArrange] 処理してください」のメッセージが出ますので、2回目の並びを削除(赤く塗りつぶされた所は直しておいてください)して、再びMyArrange処理を行います。OverlapCheck処理がうまくいった場合は「完了」メッセージが出ます。これで作業終了です。
【注意】②③で何度(3回位か?)も失敗が続く場合は、担当者2の欄の並びを全部削除して①からやり直してください。(1回目の並びに2回目がついていけないということです)
④11行×2列が終わったら、担当者2の欄に作成された2列目を入れ、3列目を作ることになります。このとき
注意しなければならないのは(最初ここで間違えた)、2列目の担当者1と場所の関係が崩れないように担当者1と場所を作り替えることです。(2列目を作ったときの担当者1と場所をコピペすれば安心です)
このようにして3列目を作ります。4列目は同じように担当者1と場所の関係が崩れないようにして作ります。(理解できますか?) この関係を崩してしまうと作成された並びはAB関係および相性関係が崩れてしまいます。
【参考】テストでは、何の問題もなく1回で処理できた場合もあり、何回も処理する場合もありました。これが条件付きのランダム処理なので仕方ないと思います。
以下はコードです。これ以上の改良はできないので、これがダメならごめんなさいです。また、コードは初級者が作っているのでグチャグチャです(試行錯誤のコードです。使わない余分なコードも入っています)。ご容赦ください。
'11人の並び処理
Sub MyArrange()
Dim gyary(11) As Variant
Dim gxary(24)
Dim i, rlen As Long

rlen = Worksheets("Sheet1").Range("C" & Rows.Count).End(xlUp).Row + 1

'担当者1の配列(変動:あ~え)
For i = rlen To 25
gxary(i - rlen) = Cells(i, 2).Value
Next i

'GY配列(固定:11人)
For i = 2 To 12
gyary(i - 2) = Cells(i, 7).Value
Next i

num = 0
Do
ReDim gyary2(11)
gyary2() = MyRnd(gyary)

'文字列にする
For i = 0 To UBound(gyary2) - 1
mystr = mystr + gyary2(i)
Next i

'相性確認
If gxary(InStr(mystr, "さ") - 1) = "あ" Or gxary(InStr(mystr, "な") - 1) = "い" _
Or gxary(InStr(mystr, "ま") - 1) = "い" Or gxary(InStr(mystr, "な") - 1) = "え" _
Or gxary(InStr(mystr, "ら") - 1) = "え" Then
'MsgBox "No"
num = num + 1
If num > 20000 Then
MsgBox "20,000回試しましたが答えが出ませんでした。やり直してください。"
Exit Sub
End If
Else
MsgBox "Yes" & vbCrLf & "適切な並びができました。"
For i = rlen To UBound(gyary2) + rlen
Cells(i, 3).Value = gyary2(i - rlen)
Next i
Exit Sub
End If
Loop
MsgBox "完了"
End Sub

'ランダム処理(並びを作る)
Function MyRnd(gyary() As Variant) As Variant
Dim i, rn, temp

'ランダム処理
For i = 0 To UBound(gyary) - 1
Randomize
rn = Int(UBound(gyary) * Rnd)
tmp = gyary(i)
gyary(i) = gyary(rn)
gyary(rn) = tmp
Next

MyRnd = gyary
End Function

'AB重複チェックとメンバー修正
Sub OverlapCheck()
Dim i, j, rlen As Long
Dim myinstr1, myinstr2

rlen = Worksheets("Sheet1").Range("C" & Rows.Count).End(xlUp).Row

'1回目の組合せから氏名、AB、氏名文字列
ReDim myary1(11, 2)
For i = 2 To 12
myary1(i - 2, 0) = Cells(i, 3).Value
myary1(i - 2, 1) = Cells(i, 4).Value
mystr1 = mystr1 + myary1(i - 2, 0)
Next i

'2回目の組合せから氏名、AB、担当者1、氏名文字列
ReDim myary2(11, 3)
For i = 13 To 23
myary2(i - 13, 0) = Cells(i, 3).Value
myary2(i - 13, 1) = Cells(i, 4).Value
myary2(i - 13, 2) = Cells(i, 2).Value
mystr2 = mystr2 + myary2(i - 13, 0)
Next i

'重複チェック配列
ReDim myerr(11, 4)
For i = 0 To 10
If myary2(i, 1) = myary1(InStr(mystr1, myary2(i, 0)) - 1, 1) Then
myerr(i, 0) = myary1(InStr(mystr1, myary2(i, 0)) - 1, 0)
myerr(i, 1) = InStr(mystr1, myary2(i, 0)) - 1
myerr(i, 2) = myary2(i, 1)
myerr(i, 3) = myary2(i, 2)
Else
myerr(i, 0) = ""
myerr(i, 1) = InStr(mystr1, myary2(i, 0)) - 1
myerr(i, 2) = ""
myerr(i, 3) = myary2(i, 2)
End If
Next i

'AorB入れ替え
For i = 0 To 11
If myerr(i, 0) <> "" And myerr(i, 2) = "A" Then
For j = i + 1 To 11
If myerr(j, 2) = "B" Then
'入れ替え後の相性確認
If myerr(InStr(mystr2, "さ") - 1, 0) = "あ" Or myerr(InStr(mystr2, "な") - 1, 0) = "い" _
Or myerr(InStr(mystr2, "ま") - 1, 0) = "い" Or myerr(InStr(mystr2, "ま") - 1, 0) = "い" _
Or myerr(InStr(mystr2, "な") - 1, 0) = "え" Or myerr(InStr(mystr2, "ら") - 1, 0) = "え" Then
Else
myinstr1 = InStr("さあないまいなえらえ", myerr(j, 0) & myary2(i, 2))
myinstr2 = InStr("さあないまいなえらえ", myerr(i, 0) & myary2(j, 2))
If myinstr1 = 0 And myinstr2 = 0 Then
Call MyChange(i, j, myerr())
Exit For
Else
Call ErrMsg(i, j)
Exit Sub
End If
End If
End If
Next j
ElseIf myerr(i, 0) <> "" And myerr(i, 2) = "B" Then
For j = i + 1 To 11
If myerr(j, 2) = "A" Then
'入れ替え後の相性確認
If myerr(InStr(mystr2, "さ") - 1, 0) = "あ" Or myerr(InStr(mystr2, "な") - 1, 0) = "い" _
Or myerr(InStr(mystr2, "ま") - 1, 0) = "い" Or myerr(InStr(mystr2, "ま") - 1, 0) = "い" _
Or myerr(InStr(mystr2, "な") - 1, 0) = "え" Or myerr(InStr(mystr2, "ら") - 1, 0) = "え" Then
Else
myinstr1 = InStr("さあないまいなえらえ", myerr(j, 0) & myary2(i, 2))
myinstr2 = InStr("さあないまいなえらえ", myerr(i, 0) & myary2(j, 2))
If myinstr1 = 0 And myinstr2 = 0 Then
Call MyChange(i, j, myerr())
Exit For
Else
Call ErrMsg(i, j)
Exit Sub
End If
End If
End If
Next j
End If
Next i
MsgBox "完了"
End Sub

まだ続きます。

作るのに3日かかりました。現役時代を思い出しながら作りました。現役の時、この処理ができていたら、と思うと残念です。...

  • gla********さん

    2020/6/817:09:14

    '修正処理
    Private Sub MyChange(ByVal i As Long, ByVal j As Long, ByRef myerr() As Variant)
    Dim temp

    '入替OK文字
    temp = myerr(i, 0)
    myerr(i, 0) = myerr(j, 0)
    myerr(j, 0) = temp
    myerr(i, 2) = ""
    myerr(j, 2) = ""
    Cells(i + 13, 3).Value = myerr(i, 0)
    Cells(j + 13, 3).Value = myerr(j, 0)
    myerr(i, 0) = ""
    myerr(j, 0) = ""
    End Sub

    Private Sub ErrMsg(ByVal i As Long, ByVal j As Long)
    Cells(i + 13, 3).Interior.ColorIndex = 3
    Cells(j + 13, 3).Interior.ColorIndex = 3
    MsgBox "修正不可能" & vbCrLf & "今回の並びをあきらめ、削除後、再度 [MyArrange] 処理してください。"
    End Sub

    これで終わりです。

  • その他の返信(2件)を表示

返信を取り消しますが
よろしいですか?

  • 取り消す
  • キャンセル

質問した人からのコメント

2020/6/9 10:06:54

gla********様

お時間使わせてしまって誠に申し訳ありません。
詳しい解説付きで本当に助かります。

まだ作業完了していませんが、理想に近い内容でしたのでベストアンサーにさせていただきたいと思います。(理解するにはしばらく時間がかかりそうです。。。)

早速作業進めたいとおもいます、ありがとうございました。

この質問につけられたタグ

みんなで作る知恵袋 悩みや疑問、なんでも気軽にきいちゃおう!

Q&Aをキーワードで検索:

Yahoo! JAPANは、回答に記載された内容の信ぴょう性、正確性を保証しておりません。
お客様自身の責任と判断で、ご利用ください。
本文はここまでです このページの先頭へ

「追加する」ボタンを押してください。

閉じる

※知恵コレクションに追加された質問は選択されたID/ニックネームのMy知恵袋で確認できます。

不適切な投稿でないことを報告しました。

閉じる