[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『【マクロ】シフト作成ファイルの変更』（ブク）
お世話になります。
シフト作成ファイルの変更を依頼されたのですが、素人の私の手には負えなかったのでお知恵を拝借できれば…。
もともとのコードは最後に貼りますが、変更したい点は
◆（5）➡6に変更
◆「遅」「中」「事7」はマクロを使用しない。
（マクロを使う前に最初に手入力で入れたい）
自分なりにいじってみたのですがうまくいきませんでした。
他に必要な情報はありますでしょうか？
どうぞよろしくお願いいたします。
Sub STEP000_割振りデータクリア()
Range("E6:AI65").Select
Selection.ClearContents
Range("E5").Select
End Sub
Sub STEP001_水曜_ロング担当者_割振り()
'シフト決定手順001＿水曜_嘱託割振り 「1:A」「6:中」「7:遅」
'2020年度役割名変更 〇（嘱託）⇒〇（ロング）
'変数宣言
Dim i '列数カウント用
i = 5
Dim 嘱託カウント '嘱託割振り用
Dim 初期値 '初期値記憶用
Dim k '行数カウント用
k = 6
Dim 前回k '行数記憶用
前回k = 6
Dim 最終行 '最終行カウント用
Dim ループ回数 'ループ回数確認用
ループ回数 = 1
Dim 嘱託人数
Dim n
Dim 週サイクル 週サイクル = 1
50: '最終行をカウントする
If Range("B" & k) = "" Then '最終行カウント終了
最終行 = k
GoTo 80
ElseIf Range("C" & k) = "〇(ロング)" Then
嘱託人数 = 嘱託人数 + 1
k = k + 1
GoTo 50
Else
k = k + 1
GoTo 50
End If
80: '嘱託人数のランダム値をセルに書き出す
Dim h, Num As Integer 'ランダム係数の重複回避用の配列
'配列1〜10（仮配列BOX）のランダム値を取得する
Dim Ide(1 To 10) As Integer
Randomize
For h = 1 To 嘱託人数
Do
Num = Int(Rnd() * 嘱託人数 + 1)
'Int型配列初期値=0なので、整合すればオフセット値に書き込み
Loop Until Ide(Num) = 0
Cells(68 + h, 1) = Num
'処理済みの配列No.には1を代入する
Ide(Num) = 1
Next h
嘱託カウント = Cells(68 + 週サイクル, 1)
100: '水曜日の列を検索
If Cells(4, i) = "" Then '次の処理へ
GoTo 1000
End If
'曜日列 「水」検索
If Cells(4, i) = "水" Then
GoTo 200 '水曜_嘱託担当割振り処理へ
Else
i = i + 1
GoTo 100
End If
200: '水曜_嘱託担当割振り処理
k = 6
'水曜日が祝日のばあい、その週の処理は飛ばす
If Cells(6, i) = "祝日" Then
i = i + 1
GoTo 100
End If
300:
'嘱託カウントが嘱託人数を超したときの処理
If 嘱託カウント > 嘱託人数 Then
嘱託カウント = 1
End If
'A・中・遅・書の割振りが完了したら、次の水曜日へ If Cells(68, i) = 1 And Cells(73, i) = 1 And Cells(74, i) = 1 And Cells(80, i) = 1 Then
i = i + 7
週サイクル = 週サイクル + 1
嘱託カウント = Cells(68 + 週サイクル, 1)
ループ回数 = 1
GoTo 100
End If
'嘱託者の役割がすべて埋まっていたら、次の水曜日へ
For n = 6 To 最終行
If Range("C" & n) = "〇(ロング)" Then
'嘱託で空欄の人がいればFORループを抜ける
If Cells(n, i) = "" Then
Exit For
End If
End If
If n = 最終行 Then
'嘱託者の役割が埋まっているため次の水曜日へ
i = i + 7
週サイクル = 週サイクル + 1
嘱託カウント = Cells(68 + 週サイクル, 1)
ループ回数 = 1
GoTo 100
End If
Next n
'検索行が、最終行までいったら最初から検索し直し
If k = 最終行 Then
k = 6
ループ回数 = ループ回数 + 1 'ループ回数1回追加
GoTo 300
End If
'嘱託でない場合は次の人へ
If Range("C" & k) <> "〇(ロング)" Then
k = k + 1
GoTo 300
End If
'役割がすでに決まっている人は、次の人へ
If Cells(k, i) <> "" Then
k = k + 1
GoTo 300
End If
'すでに割振りされていないかを確認
'縦 日付欄の確認
Select Case 嘱託カウント
Case 1
'すでにAが割振りされていたら次のシフトへ
If Cells(68, i) = 1 Then
嘱託カウント = 嘱託カウント + 1
GoTo 300
End If
'役がすでにループ回数回配置されていたら次の人へ
If Cells(k, 38) = ループ回数 Then
k = k + 1
GoTo 300
End If
Case 2
'すでに中が割振りされていたら次のシフトへ
If Cells(73, i) = 1 Then
k = k + 1
GoTo 300
End If
'役がすでにループ回数回配置されていたら次の人へ
If Cells(k, 43) = ループ回数 Then
k = k + 1
GoTo 300
End If
Case 3
'すでに遅が割振りされていたら次のシフトへ
If Cells(74, i) = 1 Then
k = k + 1
GoTo 300
End If
'役がすでにループ回数回配置されていたら次の人へ
If Cells(k, 44) = ループ回数 Then
k = k + 1
GoTo 300
End If
Case 4
'すでに書が割振りされていたら次のシフトへ
If Cells(80, i) = 1 Then
嘱託カウント = 嘱託カウント + 1
GoTo 300
End If
'役がすでにループ回数回配置されていたら次の人へ
If Cells(k, 50) = ループ回数 Then
k = k + 1
GoTo 300
End If
End Select
'嘱託の人が空欄の時、担当を割振り If Cells(k, i) = "" Then
Select Case 嘱託カウント
Case 1
Cells(k, i) = "A" '担当1＝「A」
Case 2
Cells(k, i) = "中" '担当2＝「中」
Case 3
Cells(k, i) = "遅" '担当3＝「遅」
Case 4
Cells(k, i) = "書" '担当4＝「書」
Case Else
Cells(k, i) = ""
End Select
嘱託カウント = 嘱託カウント + 1
k = k + 1
GoTo 300
Else
k = k + 1
GoTo 300
End If
1000:
MsgBox "水曜_ロング（旧嘱託）の割振り完了しました" & vbCrLf & _
"" & vbCrLf & _
"手動で、水曜日の" & vbCrLf & _
"「?D」" & vbCrLf & _
"「(5)」" & vbCrLf & _
"「(6)」" & vbCrLf & _
"を割振りしてください"
End Sub
Sub STEP002_メイン_シフト作成_Aから遅まで()
'シフト決定手順002＿メインシフト割振り（A〜遅)
'2020年度変更 担当名「事6」⇒?Eに変更
'変数宣言 i = 5 '列数カウント用 k = 6 '行数カウント用 Dim n 'カウント用 Dim 役割人数 '役割ができる人数カウント用 Dim 日数 '役割降り日数 Dim オフセット値 Dim 役割降りカウント Dim ループカウント '役割割り付けループ数確認 Dim ループ回数 Dim 担当 'クラス名取得 Dim 割付けNGフラグ '割り付けがいっぱいで振り分けできないフラグ
日数 = 1 ループカウント = 0 ループ回数 = 0 割付けNGフラグ = 0
'処理中メッセージ表示
UserForm1.Show vbModeless UserForm1.Repaint
50: '役割ができる人数をカウントする
If Range("B" & k) = "" Then '役割降り人数カウント終了
最終行 = k
GoTo 80
ElseIf InStr(Range("C" & k), "〇") > 0 Then
役割人数 = 役割人数 + 1
k = k + 1
GoTo 50
Else
k = k + 1
GoTo 50
End If
80: '役割人数のランダム値をセルに書き出す
Dim h, Num As Integer 'ランダム係数の重複回避用の配列
'配列1〜30（仮配列BOX）のランダム値を取得する
Dim Ide(1 To 30) As Integer
Randomize
For h = 1 To 役割人数
Do
Num = Int(Rnd() * 役割人数 + 1)
'Int型配列初期値=0なので、整合すればオフセット値に書き込み
Loop Until Ide(Num) = 0
Cells(68 + h, 1) = Num
'処理済みの配列No.には1を代入する
Ide(Num) = 1
Next h
役割降りカウント = Cells(68 + 日数, 1)
100: '役割振り終了判定
If Cells(4, i) = "" Then '次の処理へ
GoTo 1000
End If
'「土」「日」「祝日」は割振り処理なし
If Cells(4, i) = "土" Then
i = i + 1
GoTo 100
ElseIf Cells(4, i) = "日" Then
i = i + 1
GoTo 100
ElseIf Cells(6, i) = "祝日" Then
i = i + 1
GoTo 100
End If
200: '割振り処理
k = 6 '行の初期化
300: 'Ａ〜遅までの割付が完了したら、次の日の割振りへ
If Cells(68, i) = 1 And Cells(69, i) = 1 And Cells(70, i) = 1 And Cells(71, i) = 1 And Cells(72, i) = 1 _ And Cells(73, i) = 1 And Cells(74, i) = 1 Then
'次の日の割振りへ
i = i + 1
日数 = 日数 + 1
役割降りカウント = Cells(68 + 日数, 1)
GoTo 100
End If
If k = 最終行 Then '最終行判定
If Cells(68, i) = 1 And Cells(69, i) = 1 And Cells(70, i) = 1 And Cells(71, i) = 1 And Cells(72, i) = 1 _
And Cells(73, i) = 1 And Cells(74, i) = 1 Then
GoTo 300
Else
'A〜遅の役割振りができていないためやり直し
k = 6
GoTo 300
End If
End If
'役割降りカウント数を確認(役割人数を超えたら1へ）
If 役割降りカウント > 役割人数 Then
役割降りカウント = 1
End If
'全ての担当が埋まって、割り付けできないときにメッセージ表示
For n = 6 To 最終行
If InStr(Range("C" & n), "〇") > 0 Then
If Cells(n, i) <> "" Then
割付けNGフラグ = 1
Else
割付けNGフラグ = 0
Exit For
End If
End If
Next n
If 割付けNGフラグ = 1 Then
Dim rc As Integer
rc = MsgBox(i - 4 & " 日はすべて担当が埋まっており" & vbCrLf & _
"割付ができませんでした。" & vbCrLf & _
"" & vbCrLf & _
"処理を続行する場合は「はい」" & vbCrLf & _
"中断するときは「いいえ」" & vbCrLf & _
"をクリックしてください", vbYesNo + vbQuestion, "割振りNG")
If rc = vbYes Then
'次の日の割振りへ
i = i + 1
日数 = 日数 + 1
役割降りカウント = Cells(68 + 日数, 1)
GoTo 100
Else
MsgBox "処理を中断します"
End
End If
End If
'役割降りする担当がすでに配役されていないか確認 '縦 日付欄の確認 For n = 6 To 最終行
Select Case 役割降りカウント
Case 1
If Cells(n, i) = "A" Then
役割降りカウント = 役割降りカウント + 1
GoTo 300
End If
Case 2
If Cells(n, i) = "B" Then
役割降りカウント = 役割降りカウント + 1
GoTo 300
End If
Case 3
If Cells(n, i) = "C" Then
役割降りカウント = 役割降りカウント + 1
GoTo 300
End If
Case 4
If Cells(n, i) = "D" Then
役割降りカウント = 役割降りカウント + 1
GoTo 300
End If
Case 5
If Cells(n, i) = "E" Then
役割降りカウント = 役割降りカウント + 1
GoTo 300
End If
Case 6
If Cells(n, i) = "中" Then
役割降りカウント = 役割降りカウント + 1
GoTo 300
End If
Case 7
If Cells(n, i) = "遅" Then
役割降りカウント = 役割降りカウント + 1
GoTo 300
End If
End Select
Next n
'役割降りできないメンバーのときは次の人へ
If InStr(Range("C" & k), "〇") = 0 Then
k = k + 1
GoTo 300
End If
'空欄セルか確認 If Cells(k, i) = "" Then
'担当者 役回数の確認
'役割降りカウントが、割付役以外の時は、ループ回数確認を飛ばす
If 役割降りカウント > 8 Then
GoTo 400
End If
'ループ回数確認
If Cells(k, 37 + 役割降りカウント) = ループ回数 Then
GoTo 400 '役割降りへ
Else
ループカウント = ループカウント + 1
If ループカウント = 最終行 - 4 Then
ループ回数 = ループ回数 + 1
End If
k = k + 1
GoTo 300
End If
400: '同クラスの割振り判定
'同クラスで「1:A」「2:B」「3:C」「4:D」「5:E」を占有してはダメ 担当 = Cells(k, 4)
'役割降りカウントが「5:E」までだったとき If 役割降りカウント < 6 Then
'担当が一人しかいないときは割振りOK
If Range("BA" & k) = 1 Then
GoTo 600
End If
For n = 6 To 最終行
If Cells(n, 4) = 担当 Then
'自分の行は、確認を飛ばす
If n = k Then
GoTo 450
End If
'役割「×」のときは、確認を飛ばす
If Cells(n, 3) = "×" Then
GoTo 450
End If
'同クラスで、A,B,C,D,Eの人がいる場合、役割降りNG
If Cells(n, i) = "A" Or Cells(n, i) = "B" Or Cells(n, i) = "C" Or _
Cells(n, i) = "D" Or Cells(n, i) = "E" Then
'割振りを次の人へ
k = k + 1
GoTo 300
Else
'次の行確認
GoTo 450
End If
'氏名が空欄になったら、役割降りOK
ElseIf Cells(n, 2) = "" Then
GoTo 600
'担当が「フリー」の場合は、担当割振りOK
ElseIf Cells(n, 3) = "フリー" Then
'役割降りOKのため
GoTo 600
Else
GoTo 450
End If
450: Next n
End If
500: '同クラスの割振り判定
'同クラスで「6:中」「7:遅」が重なってはダメ
'役割降りカウントが「6:中」「7:遅」だったとき
If 役割降りカウント = 6 Or 役割降りカウント = 7 Then
For n = 6 To 最終行
If Cells(n, 4) = 担当 Then
'自分の行は、確認を飛ばす
If n = k Then
GoTo 550
End If
'役割「×」のときは、確認を飛ばす
If Cells(n, 3) = "×" Then
GoTo 550
End If
'同クラスで、中 ,遅 の割り付けのがいる場合は
'役割降りNG
If Cells(n, i) = "中" Or Cells(n, i) = "遅" Then
k = k + 1
GoTo 300
'氏名が空欄になったら、役割降りOK
ElseIf Cells(n, 2) = "" Then
GoTo 600
'担当がフリーであれば、割り付けOK
ElseIf Cells(n, 3) = "フリー" Then
GoTo 600
Else
GoTo 550
End If
End If
550: Next n
End If
600: '役割降りの入力
Select Case 役割降りカウント
Case 1
Cells(k, i) = "A"
Case 2
Cells(k, i) = "B"
Case 3
Cells(k, i) = "C"
Case 4
Cells(k, i) = "D"
Case 5
Cells(k, i) = "E"
Case 6
Cells(k, i) = "中"
Case 7
Cells(k, i) = "遅"
Case Else
Cells(k, i) = ""
End Select
役割降りカウント = 役割降りカウント + 1
ループカウント = 0
ループ回数 = 0
k = k + 1
GoTo 300
Else
k = k + 1
GoTo 300
End If
1000:
'処理中メッセージを消す
Unload UserForm1
MsgBox "メインの割振り（Ａ〜遅まで）完了しました"
End Sub
Sub STEP003_メイン_シフト作成_?Dから事7まで()
'シフト決定手順003＿メインシフト割振り（?D〜事7)
'変数宣言 i = 5 '列数カウント用 k = 6 '行数カウント用 Dim n 'カウント用 Dim 役割人数 '役割ができる人数カウント用 Dim 日数 '役割降り日数 Dim オフセット値 Dim 役割降りカウント Dim ループカウント '役割割り付けループ数確認 Dim ループ回数 Dim 担当 'クラス名取得 Dim 割付けNGフラグ '割り付けがいっぱいで振り分けできないフラグ
日数 = 1 ループカウント = 0 ループ回数 = 0 割付けNGフラグ = 0
'処理中メッセージ表示
UserForm1.Show vbModeless UserForm1.Repaint
50: '役割ができる人数をカウントする
If Range("B" & k) = "" Then '役割降り人数カウント終了
最終行 = k
GoTo 80
ElseIf InStr(Range("C" & k), "〇") > 0 Then
役割人数 = 役割人数 + 1
k = k + 1
GoTo 50
Else
k = k + 1
GoTo 50
End If
80: '役割人数のランダム値をセルに書き出す
Dim h, Num As Integer 'ランダム係数の重複回避用の配列
'配列1〜30（仮配列BOX）のランダム値を取得する
Dim Ide(1 To 30) As Integer
Randomize
For h = 1 To 役割人数
Do
Num = Int(Rnd() * 役割人数 + 1)
'Int型配列初期値=0なので、整合すればオフセット値に書き込み
Loop Until Ide(Num) = 0
Cells(68 + h, 1) = Num
'処理済みの配列No.には1を代入する
Ide(Num) = 1
Next h
役割降りカウント = Cells(68 + 日数, 1)
100: '役割振り終了判定
If Cells(4, i) = "" Then '次の処理へ
GoTo 1000
End If
'「土」「日」「祝日」は割振り処理なし
If Cells(4, i) = "土" Then
i = i + 1
GoTo 100
ElseIf Cells(3, i) = "日" Then
i = i + 1
GoTo 100
ElseIf Cells(6, i) = "祝日" Then
i = i + 1
GoTo 100
End If
200: '割振り処理
k = 6 '行の初期化
300:
If Cells(81, i) >= 12 Then
'次の日の割振りへ i = i + 1 日数 = 日数 + 1 役割降りカウント = Cells(68 + 日数, 1)
GoTo 100
End If
If k = 最終行 Then '最終行判定
If Cells(81, i) <= 11 Then 'すべての役割振りができていないためやり直し
k = 6
GoTo 300
End If
End If
'役割降りカウント数を確認(役割人数を超えたら1へ）
If 役割降りカウント > 役割人数 Then
役割降りカウント = 1
End If
'全ての担当が埋まって、割り付けできないときにメッセージ表示
For n = 6 To 最終行
If InStr(Range("C" & n), "〇") > 0 Then
If Cells(n, i) <> "" Then
割付けNGフラグ = 1
Else
割付けNGフラグ = 0
Exit For
End If
End If
Next n
If 割付けNGフラグ = 1 Then
Dim rc As Integer
rc = MsgBox(i - 4 & " 日はすべて担当が埋まっており" & vbCrLf & _
"割付ができませんでした。" & vbCrLf & _
"" & vbCrLf & _
"処理を続行する場合は「はい」" & vbCrLf & _
"中断するときは「いいえ」" & vbCrLf & _
"をクリックしてください", vbYesNo + vbQuestion, "割振りNG")
If rc = vbYes Then
'次の日の割振りへ
i = i + 1
日数 = 日数 + 1
役割降りカウント = Cells(68 + 日数, 1)
GoTo 100
Else
MsgBox "処理を中断します"
End
End If
End If
'役割降りする担当がすでに配役されていないか確認 '縦 日付欄の確認 For n = 6 To 最終行
Select Case 役割降りカウント
Case 1
If Cells(n, i) = "?D" Then
役割降りカウント = 役割降りカウント + 1
GoTo 300
End If
Case 2
If InStr(Cells(n, i), "(5)") > 0 Then
役割降りカウント = 役割降りカウント + 1
GoTo 300
End If
Case 3
If InStr(Cells(n, i), "(6)") > 0 Then
役割降りカウント = 役割降りカウント + 1
GoTo 300
End If
Case 4
If Cells(n, i) = "?E" Then
役割降りカウント = 役割降りカウント + 1
GoTo 300
End If
Case 5
If Cells(n, i) = "事7" Then
役割降りカウント = 役割降りカウント + 1
GoTo 300
End If
End Select
Next n
'役割降りできないメンバーのときは次の人へ
If InStr(Range("C" & k), "〇") = 0 Then
k = k + 1
GoTo 300
End If
'空欄セルか確認 If Cells(k, i) = "" Then
'担当者 役回数の確認
'役割降りカウントが、5役以外の時は、ループ回数確認を飛ばす
If 役割降りカウント > 5 Then
GoTo 600
End If
'ループ回数確認
If Cells(k, 44 + 役割降りカウント) = ループ回数 Then
GoTo 600 '役割降りへ
Else
ループカウント = ループカウント + 1
If ループカウント = 最終行 - 4 Then
ループ回数 = ループ回数 + 1
End If
k = k + 1
GoTo 300
End If
600: '役割降りの入力
Select Case 役割降りカウント
Case 1
Cells(k, i) = "?D"
Case 2
Cells(k, i) = "'(5)"
Case 3
Cells(k, i) = "'(6)"
Case 4
Cells(k, i) = "?E"
Case 5
Cells(k, i) = "事7"
Case Else
Cells(k, i) = ""
End Select
役割降りカウント = 役割降りカウント + 1
ループカウント = 0
ループ回数 = 0
k = k + 1
GoTo 300
Else
k = k + 1
GoTo 300
End If
1000:
'処理中メッセージを消す
Unload UserForm1
MsgBox "メインの割振り（?D〜事7まで）完了しました"
End Sub
＜ 使用 Excel：Excel2016、使用 OS：Windows10 ＞
2022 年 7 月 日付 7/1 7/2 7/3 7/4 7/5 7/6 7/7 7/8 曜日 金 土 日 月 火 水 木 金 No 氏名 役割 担当 1 スタッフ1 × 2 スタッフ2 × 3 スタッフ3 〇 あ担当 中 休 休 D 中 C ?D 中 4 スタッフ4 〇 あ担当 遅 休 休 E 遅 D A 遅 5 スタッフ5 〇 い担当 D 休 休 中 事7 B (6) 6 スタッフ6 〇 あ担当 E 休 休 遅 (5) E 7 スタッフ7 〇 う担当 休 休 C A E C 事7 （ブク） 2022/05/06(金) 16:25
A B C D E 中 遅 ?D （6） 事6 6 事7
これだけのパターンがあるそうです。
最初のやりたいことに書いてなかったですが、このマクロには「事6」がないような気がします。
やりたいことを再度まとめました。
もともとのコードは最後に貼りますが、変更したい点は
◆（5）➡6に変更
◆「遅」「中」「事7」はマクロを使用しない。
（マクロを使う前に最初に手入力で入れたい）
◆「事6」を追加
どうぞよろしくお願いいたします。
（ブク） 2022/05/06(金) 16:35
概略の説明もなしに、これだけのボリュームの物を読みこなしてくださる方がおられるかどうか。
もう少し、背景なり概要の説明があったほうが、物事が進むでしょうね。
# ちなみに私は外出中でして、今は着手はできませんが、確認やらお願いだけをしています。
（γ） 2022/05/06(金) 16:43
作成者（不明）➡前担当➡今年度担当➡使い方がわからなくて（ブク）に相談
の経緯でした。
私自身シフト作成業務にはかかわっておらず（知人に相談された部外者です）、なおかつ素人の手が出せるファイルでないということならあきらめがつくので、それがわかっただけでもありがたいです。
お忙しい中コメントを下さりありがとうございました。
（ブク） 2022/05/06(金) 17:17
＞自分なりにいじってみたのですがうまくいきませんでした。
どのようにうまくいかなかったのか説明があればその部分くらいは解決するかもしれませんが、業務を知らない人が業務で使うプログラムを組むのは無理があるとおもいます。
踏まえて、シフト作成業務にかかわってないだけで業務自体は分かるということならば、最初から設計しなおしたほうが早いんじゃないかなとおもいました。
感想だけですがすみませんが・・・
（もこな２） 2022/05/06(金) 19:19
そうですね…シフトを組む担当者本人があまりExcelを使い慣れていなくて
このファイルの使い方がわからないというのが現状で、しかも担当者は数年単位で
変わっていくこともわかっているうえ、エクセルのスキルもバラバラであると予想されます。
そもそも素人がメンテナンスできないファイルというのが問題ですよね。
マクロ自体は、13種類あるシフトを自動で入力するものですが、思い通りに入れたいという
こともあるようです。（大変でしょうけど）
一からの組みなおし、確かにその方がいいのかもしれません。
現担当者は、できなければ手入力でやりますと言っているので、私のできる範囲でサポート
したいと思います。
また何かあれば改めて書き込みさせていただくこともあるかと思います。
その時はどうぞよろしくお願いいたします。
（ブク） 2022/05/06(金) 19:30
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.