[[20170217080857]] 『勤務表 当直5人ランダムしたいです 別人』(トラ) >>BOT

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『勤務表 当直5人ランダムしたいです 別人』(トラ)

勤務表 当直5人ランダムしたいですの質問で、
長くなりすぎたので、別にしました。

質問に返答が無いので、勝手に条件を決めました。

1
当直のない日は、1年を通して一日もない (祝日も当直をする)
当直は、午前八時から翌日の午前八時まで
連続当直は無 連続当直・・・当直明けからすぐに次の当直に入ること
当直は、5人で行う
電気担当が3人、空調担当が1人、水道担当が1人で行う
シフトスケジュール表来月まで作成する
半日当直とかは無い・・実際に有ったとしてもこのスケジュール表上では扱えない

2
専任職員が15〜20人
委員職員は、5〜8人
当直は、5人で行う 専任職員 - 3人,委員職員 - 1人, 当直回数の少ない人 - 1人
専任、委員で当直回数を区別しない
途中で参加する人は、E列の該当行にその開始日を入れる (シリアル値)
途中で終わる人は、F列の該当行にその終了日を入れる (シリアル値)

プログラムでのスケジュール
3
休日希望を入力できる、休日直前日の当直は不可
当直希望を入力できる・・・連続当直は無
例外を除いて一日あたりの(休日希望+当直希望)は人数の1/3まで(四捨五入)とする
(専任職員が15人、委員職員5人だとしたら専任職員が5人、委員職員2人まで)
前々月、前月、当月での当直回数の平均化
土日の当直の平均化・・・祝日は無視する
電気担当、空調担当人、水道担当の平均化
電気担当・・・資格を持っていれば電気担当にする
人物の組み合わせは同じメンバーになっても良い
休日希望,当直希望が無ければ、当直,休日(3〜2),当直,休日(3〜2),当直,休日(3〜2)にする
休日希望 , 当直希望があれば、その時当直間隔が隔日になることがある

4
スケジュール表の変更方法
3 で記入した希望日は変更しない
全員のスケジュール変更は、当日から7日目以降
個別のスケジュール変更は、当日から可能
個別のスケジュール変更は、2人以上同時に行わないと、当直回数のばらつきが大きくなる

5
人員の増員時の方法
最終行の下に、名前 所属 専門 初日 を記入
初日の記入を忘れずに。
初日の日付けが当月来月の日付けだったら、その日付け以降のスケジュールを再計算する

人員の減員時の方法
その人物の終了日に日付けを書き込む
終了日の日付けが当月来月の日付けだったら、その日付け以降のスケジュールを再計算する
その人物の行が全て0になっていることを確認して行削除する

6
休日希望はどれぐらいの頻度か 25%以下
当直希望はどれぐらいの頻度か あまり無い
当直は少ない方が良いと感じているのか 多くても少なくてもでも良い
電気担当、空調担当、水道担当 良い悪いは無い

7
例外1
専任職員全員が当直無(忘年会等)の時、委員職員5人当直する
その時の記入方法・・・委員職員5人を当直希望と前もって記入する
その時、当直間隔が隔日になることがある

例外2
委員職員全員が当直無(忘年会等)の時、専任職員5人当直する
その時の記入方法・・・委員職員全員を休日希望と前もって記入する
委員職員 - 0人が二日できる
その時、当直間隔が隔日になることがある

< 使用 Excel:unknown、使用 OS:WindowsXP >


'まっさらのSheets("Sheet1")に最初に実行
'AA列5行目以降のスケジュール表内の文字色は変えてはいけない
'罫線で囲まれた項目の配置変更はできない。彩色は自由

Sub Sh1_1見出しと罫線のセット()

    Dim sss, i, j, k
    Dim Ws As Worksheet, regAA2 As Range

    Sheets("Sheet1").Select
    Rows(2).Resize(3).HorizontalAlignment = xlCenter

    Cells(3, "H").Resize(, 6).Merge
    Cells(3, "N").Resize(, 6).Merge
    Cells(3, "T").Resize(, 6).Merge
    Cells(3, "H").Value = "過去一月の"
    Cells(3, "N").Value = "当月の"
    Cells(3, "T").Value = "来月の"
    sss = "名前,所属,専門,初日,終了日,,当直数,日数補正,土日,電気,空調,水道,当直数,日数補正,土日,電気,空調,水道,当直数,日数補正,土日,電気,空調,水道"
    sss = Split(sss, ",")
    Cells(4, "B").Resize(, UBound(sss) + 1).Value = sss
    Cells(5, "B").Resize(22).Value = "名前1to22"
    Cells(5, "C").Resize(15).Value = "専任"
    Cells(20, "C").Resize(6).Value = "委員"
    Cells(26, "C").Value = "専任"
    Cells(5, "H").Resize(22).Value = 7
    Cells(5, "G").Resize(22).Formula = "=SUM(H5,N5,T5)"

    Rows(20).Resize(6, 100).Interior.ColorIndex = 6

    Set regAA2 = Cells(2, "AA").Resize(42, 67)
    regAA2.Resize(1).NumberFormatLocal = "M"
    regAA2.Resize(1).Offset(1).NumberFormatLocal = "D"
    regAA2.Resize(1).Offset(2).NumberFormatLocal = "aaa"

    Cells(3, "H").Resize(41, 18).Borders.LineStyle = True
    Cells(4, "B").Resize(40, 5).Borders.LineStyle = True
    regAA2.Borders.LineStyle = True

    regAA2.ColumnWidth = 3.5
    regAA2.Resize(3, 67).Interior.ColorIndex = 35

End Sub

返答が無ければ、これで終わりにします。
(トラ) 2017/02/17(金) 08:21


 このトピの続きですね
[[20170202151355]]
(通りすがり) 2017/02/18(土) 07:50

 テーマが似てるんで、載せておきます。
 『ゴミ当番表の作成』(しあわせブタ)
[[20170121151519]]
(通りすがり) 2017/02/18(土) 11:09

トラ様へ
返信遅れてすみません。
今年4月からルール変えまして、条件相談中です、
迷惑を掛けますがしばらくお持ち下さい。
今日か明日、投稿する予定です。
申し訳がありません。
(SinNeo) 2017/02/18(土) 17:12

トラ様へ
返信遅れて申し訳がありません。
コード表ありがとうございます。
この通り条件いいと思いますが、今年4月からルール変更がありまして、条件相談し上記の条件の修正・追加作成しましたので下記の条件で大丈夫でしょうか?
文字変更
委員職員 → 委託職員
電気当直担当 → 中央棟当直「当」
水道当直担当 → 入院棟当直「入」
空調当直担当 → 防災当直「防」
1、当直
・当直のない日は、1年を通して一日もない (祝日も当直をする)
・当直は、午前8時半から翌日の午前8時半まで
・連続当直は無し 連続当直・・・当直明けからすぐに次の当直に入ること
・当直は、5人で行う
・中央棟担当が3人、入院棟担当が1人、防災担当が1人で行う
・シフトスケジュール表は来月まで作成する
・同姓同名は避ける、片方を平仮名にするとかする
・半日当直とかは無し
・出来れば当直は、現在5人で行うが、将来、増やす(減らす)可能性がありますので、当直人数変更を出来るようにしたい
・当直基本、専任職員‐3人以上 委託職員‐2人以上(出来れば、将来、専任職員当直減らし委託職員増やす可能性がありますので、当直人数変更を出来るようにしたい)
・各1人 金曜日当直1回 土曜日当直1回 日曜日当直1回する事(専任職員だけなんけど、将来、専任職員も委託職員も回数選べるようにしたい)
・当直平均化
・中央棟当直だけの人(監視責任者の為)を設定したい (理想ですが、別のシートで各1人ずつ当直の別々チェックボックスような入れたり外したりようなしたい。)
・資格によって、防災当直だけ除いて中央棟当直と入院当直担当する。(入院当直だけ除いて中央棟当直と防災当直担当する。)(理想ですが、別のシートで各1人ずつ別々チェックボックスような入れたり外したりようなしたい。)
2、人数・回数
・専任職員は、0〜40人(理想)
・委託職員は、0〜40人(理想)
・専任職員、委託職員の順に名簿に記入
・専任、委員で当直回数を区別しない
・途中で参加する人は、E列の該当行にその開始日を入れる (シリアル値)
・途中で終わる人は、F列の該当行にその終了日を入れる (シリアル値)
・各1人 中央棟当直回数は制限なし
・各1人 入院棟当直回数は1〜3回
・各1人 防災当直回数は1〜3回
・前々月、前月、当月での当直回数の平均化
・土日の当直の平均化・・・祝日は無視する
・各1人当直回数は、月によって6〜8回
3、予定・休日・メンバー・表示
・休日希望を入力できる、休日直前日の当直は不可
・当直希望を入力できる・・・連続当直は無
・人物の組み合わせはランダムによって同じメンバーになっても良い
・休日希望,当直希望が無ければ、当直,休日(3〜2),当直,休日(3〜2),当直,休日(3〜2)にする →なし
・基本 専任職員の休日は、6回 委託職員の休日は、8回(理想、休日回数変更したい。)
・休日希望はどれぐらいの頻度か→専任職員の休日は、月によって6〜8回 委託職員の休日は、月によって6〜9回
・基本、土曜日→「週」 日曜日→「休」と表示したい
・出張→「出」 有休→「有」 代休→「代」当直明け→「×」施設→「施」と表示したい
・予定→「予」と表示するが、出来れば非表示したい
・出来れば、別のシートで自分で2つの上みたく入力してリフトして選びたい、そうすれば各1人別のシート作りたい。
4、スケジュール表の変更方法
当日から来月のスケジュール表を再計算する。
3で記入した希望日は変更しない。ちゃんと締め切りがあります。
5、人員の増員時の方法(いいと思います)
専任職員増 行を挿入し、名前 所属 専門 初日 を記入
委員職員増 最終行の下に、名前 所属 専門 初日 を記入
初日の記入を忘れずに、スケジュール表の再計算をする
人員の減員時の方法
終日を記入
終日から一月以上過ぎていること
その人物の行を削除する
6、日勤(出来れば)
・日勤は、中央棟日勤、入院棟日勤、大学棟日勤3つあります。
・回数は制限なし (出来れば、中央棟日勤だけの人(監視責任者のため)設定したい )
 (中央棟日勤だけの人いますが、たまに入院棟・大学棟日勤、数回したい)
 (理想ですが、別のシートで各1人ずつ別々チェックボックスような入れたり外したりようなしたい。)
・基本
 中央棟日勤は、当直や休日など以外残りが中央棟日勤
 入院棟日勤は、2人
 大学棟日勤は、2人
・表示はなしで、背色したい(7、色へ)
7、色
・中央棟日勤→塗るつぶしなし
・入院棟日勤→白 背1、黒+基本色25%
・大学棟日勤→白 背1、黒+基本色50%
・中央棟当直→塗るつぶしなし
・中央棟当直3人内1人(中央棟当直だけの人は除いて)→白 背1、黒+基本色50%
・入院棟当直→白 背1、黒+基本色25%
・防災当直→白 背1、黒+基本色25%
・出張→オレンジ
・施設→オリーブ、アクセント3、白+基本60%
8、例外
例外1
専任職員全員が当直無(忘年会等)の時、委員職員5人当直する
その時の記入方法・・・委員職員5人を当直希望と前もって記入する
その時、当直,休日(1〜),当直でも良い (休日,当直でも良い)
例外2
委員職員全員が当直無(忘年会等)の時、専任職員5人当直する
その時の記入方法・・・委員職員全員を休日希望と前もって記入する
委員職員 - 0人が二日できる
その時、当直,休日(1〜),当直でも良い (休日,当直でも良い)
言葉が悪いのは、分かってますが
マリオ様が作ったファイルような(すみません)みたくが分かりやすくていいなと思います、、
VBA初心者ですみません。
迷惑をかけて申し訳がありません。
勉強になりますのでお手数ですが、よろしくお願い致します。
何かあれば言ってください。
気にしないで下さい↓↓
当直の回数をはじめに指定
・金曜日と土曜日当直した人は、半休となり0.5日とする。
  ・半休二つがあったら、1日休みとする
・・・・休みだから何
祝日の扱い
(SinNeo) 2017/02/19(日) 04:18

SINNEOさんへ

私の造ったコードを実行してみましたか。
その結果を何も報告せずに、注文だけつけると、
マリオさんの言われた「誠意がまったく感じられません」となります。

私の造ったコードを実行して、マリオ様が作ったファイルを比べて見にくいと感じられたと思います。
それは、当然です。マリオ様の表は、スケジュールの決定した表から、見やすいように変換した物です。
マリオ様の表ではプログラムは組めません。前月、来月、その他諸々の情報がないからです。
私の表の罫線で囲まれた部分の配置は、変更できません。最大行数は増減できます。

スケジュール機能が満足できる物だ出来たら、それを見やすい形にするのは、そちらでやってもらうしかないです。
中間の列を非表示にする位ならすぐに出来ますが

委員職員 → 委託職員・・可能です。
略号に当の文字が入っていないとだめです。
電気当直担当 → 中央棟当直「当」・・・「当中」
水道当直担当 → 入院棟当直「入」・・・「当入」
空調当直担当 → 防災当直「防」 ・・・「当防」

・■各1人 金曜日当直1回 土曜日当直1回 日曜日当直1回する事・・・出来ない
・・・金土日のどれか一日、例えば土曜日を当直最大1回にする事はできる。

(専任職員だけなんけど、将来、専任職員も委託職員も回数選べるようにしたい)・・・出来ない
・・・当直回数は、職員数で自動的に決まる

・■中央棟当直だけの人(監視責任者の為)を設定したい ・・・人数が少なければ可能、人数?

 (理想ですが、別のシートで各1人ずつ当直の別々チェックボックスような入れたり外したりようなしたい。)・・・出来ない
・■資格によって、防災当直だけ除いて中央棟当直と入院当直担当する。・・・資格所有人数が少なければ可能 人数?
・・・上三行は、もっと詳しく例を示して説明してください。

・出来れば当直は、現在5人で行うが、将来、増やす(減らす)可能性がありますので、当直人数変更を出来るようにしたい
・当直基本、専任職員‐3人以上 委託職員‐2人以上(出来れば、将来、専任職員当直減らし委託職員増やす可能性がありま

すので、当直人数変更を出来るようにしたい)
・・・現状では、専任職員‐3人、委託職員‐1人、当直回数の少ない人1人と成っています。
・・・自動での、変更は出来ませんが、専任職員‐1人、委託職員‐3人、当直回数の少ない人1人とかの変更は可能です。

・専任職員は、0〜40人(理想) ・・・各1人当直回数は、月に6〜8回・一日5人 
・委託職員は、0〜40人(理想) ・・・上記の計算で、専任職員+委託職員が、23人前後にする

・■基本 専任職員の休日は、6回 委託職員の休日は、8回(理想、休日回数変更したい。)  
・・・休日の意味が解らない 当直を回避できる日が6回とか8回あるという意味かな
・・・職員数23人で当直を行うと平均4日(当直、当直明け、休み、休み)に一回当直が回ってきます。
・・・月の半分の日数が休日になる計算ですが 

・基本、土曜日→「週」 日曜日→「休」と表示したい ・・・だめ
・・・休日希望の時「休」という文字を使う。また「土」の文字も必要

・出張→「出」 有休→「有」 代休→「代」当直明け→「×」施設→「施」と表示したい 
・・・出張→「出休」 有休→「有休」 代休→「代休」・・・「休」の文字を入れる
・・・当直明け→「×」そのような物は造らない、前日の当直希望に一本化 
・■・・施設→「施」は何の事か説明が無い

・■予定→「予」と表示するが、出来れば非表示したい・・・「予」は何の事か説明が無い

・出来れば、別のシートで自分で2つの上みたく入力してリフトして選びたい、そうすれば各1人別のシート作りたい。
・・・これは、スケジュール表の機能が出来上がった上で、きっちり仕様を決めてください。・・・現状ではだめ

4、スケジュール表の変更方法
当日から来月のスケジュール表を再計算する。
3で記入した希望日は変更しない。ちゃんと締め切りがあります。
・・・急病や交通事故などで変更は必ず発生する。
・・・個別のスケジュール変更は、当日から可能。
・・・全部の、再計算は、7日目以降から可能
・・・スケジュールを再計算する時、3で個別に入力した予定は変更しない

・6、日勤(出来れば)・・・
これをやるためには日勤のために、今回当直のため書かれた1〜5に相当する物を書く必用があります。
今書かれている事だけでは、判断できません。

・7、色
・・・簡単に出来ると思いますが本体が出来上がってから
・・・色は、カラーナンバーで指定してください。

■の部分は早急に返答してください。
当直間隔については重視していないような感じを受けたのですが、
月の前半に隔日当直が集中し後半は週一の当直でも、問題ないのかな
(トラ) 2017/02/19(日) 18:18


前回の返答に間違いがありました。

・■各1人 金曜日当直1回 土曜日当直1回 日曜日当直1回する事
当直メンバーが30人くらい居たら、出来ます。
そのわけは、金土日が月に5回有る時がある。その時一回限りにするには、当直5人×5=25人必用です。

(トラ) 2017/02/20(月) 00:42


一応、形に成りましたのでアップします
Sub A_Main()を実行してみてください。

Sub A_Main()

    Randomize

    Call Sh1_2前月末5日_当月_来月表を当月末5日_来月_来来月にする

    Call Sh1_02初日終了日で当直日数補正

    Call Sh1_4三ヶ月のスケジュール表に当直を記入の予備動作

    Call Sh1_6スケジュール表に当直を計算

    Call Sh1_6当直を中央棟担当_入院棟担当_防災担当に振り分ける

End Sub

'人員の増減が有った時に実行、当直数のばらつきが大きい時があるのでその時も実行
Sub B_Clear()

    Call sh1_40指定日以降のスケジュールをクリアする
End Sub

Option Explicit
Option Private Module

Sub Sh1_6スケジュール表に当直を計算()

    Const AAA As Long = 5    '一日に当直者数・・・専任+委託+当直の少ない人
    Const BBB As Long = 3    '専任の当直者数
    Const CCC As Long = 1    '委託の当直者数

    Dim i As Long, j As Long, k As Long, n As Long
    Dim xRow As Long, MaxRow As Long, iMember As Long
    Dim Ws As Worksheet
    Dim myRange As Range, xRange As Range, regAA2 As Range
    Dim xDate As Date, myDate As Date, yDate As Date, AFDate As Date
    Dim AFColumn As Long, CLColumn As Long, xColumn As Long

    Call SetDimName_(Ws, MaxRow, iMember, AFColumn, CLColumn, regAA2, AFDate)

    Dim i当 As Long, i当専任 As Long, i当委託 As Long
    Dim Buf As Variant, kkk As Long, iii As Long
    Dim ttt4 As Long, ttt5 As Long, ttt8 As Long, ttt9 As Long
    Dim tukiColumn As Long, s専任委託 As String

    Ws.Cells(5, "N").Resize(iMember, 1).ClearContents
    Ws.Cells(5, "P").Resize(iMember, 5).ClearContents
    Ws.Cells(5, "V").Resize(iMember, 4).ClearContents

    For xColumn = AFColumn To CLColumn
        yDate = Ws.Cells(3, xColumn).Value

        i当 = WorksheetFunction.CountIf(Ws.Cells(5, xColumn).Resize(iMember), "*当*")
        If i当 > 5 Then
            MsgBox "当直 > 5 Error"
            MsgBox Ws.Cells(5, xColumn).Resize(iMember).Address
            End
        End If

        i当専任 = 0
        i当委託 = 0
        For j = 5 To MaxRow
            Buf = Ws.Cells(j, xColumn).Value
            If Buf Like "*当*" Then
                If Ws.Cells(j, "C").Value Like "*専任*" Then
                    i当専任 = i当専任 + 1
                Else
                    i当委託 = i当委託 + 1
                End If
            End If
        Next j

        '3専任職員
        s専任委託 = "*専任*"
        n = 4
        For k = 1 To 3 - i当専任
            Call Sh1_6088スケジュール表に当直を計算(Ws, n, s専任委託, MaxRow, xColumn, AFDate, yDate, _
                                       xRow, i当専任, i当委託, j, Buf, kkk, ttt4, ttt5, ttt8, ttt9)
        Next k
        n = 3
        For k = 1 To 3 - i当専任
            Call Sh1_6088スケジュール表に当直を計算(Ws, n, s専任委託, MaxRow, xColumn, AFDate, yDate, _
                                       xRow, i当専任, i当委託, j, Buf, kkk, ttt4, ttt5, ttt8, ttt9)
        Next k
        n = 2
        For k = 1 To 3 - i当専任
            Call Sh1_6088スケジュール表に当直を計算(Ws, n, s専任委託, MaxRow, xColumn, AFDate, yDate, _
                                       xRow, i当専任, i当委託, j, Buf, kkk, ttt4, ttt5, ttt8, ttt9)
        Next k

        '1委託職員
        s専任委託 = "*委託*"
        n = 4
        For k = 1 To 1 - i当委託
            Call Sh1_6088スケジュール表に当直を計算(Ws, n, s専任委託, MaxRow, xColumn, AFDate, yDate, _
                                       xRow, i当専任, i当委託, j, Buf, kkk, ttt4, ttt5, ttt8, ttt9)
        Next k
        n = 3
        For k = 1 To 1 - i当委託
            Call Sh1_6088スケジュール表に当直を計算(Ws, n, s専任委託, MaxRow, xColumn, AFDate, yDate, _
                                       xRow, i当専任, i当委託, j, Buf, kkk, ttt4, ttt5, ttt8, ttt9)
        Next k
        n = 2
        For k = 1 To 1 - i当委託
            Call Sh1_6088スケジュール表に当直を計算(Ws, n, s専任委託, MaxRow, xColumn, AFDate, yDate, _
                                       xRow, i当専任, i当委託, j, Buf, kkk, ttt4, ttt5, ttt8, ttt9)
        Next k

        '1全職員
        i当 = WorksheetFunction.CountIf(Ws.Cells(5, xColumn).Resize(iMember), "*当*")
        s専任委託 = "*"
        n = 4
        For k = i当 + 1 To 5
            Call Sh1_6088スケジュール表に当直を計算(Ws, n, s専任委託, MaxRow, xColumn, AFDate, yDate, _
                                       xRow, i当専任, i当委託, j, Buf, kkk, ttt4, ttt5, ttt8, ttt9)
        Next k

        '1全職員
        i当 = WorksheetFunction.CountIf(Ws.Cells(5, xColumn).Resize(iMember), "*当*")
        s専任委託 = "*"
        n = 3
        For k = i当 + 1 To 5
            Call Sh1_6088スケジュール表に当直を計算(Ws, n, s専任委託, MaxRow, xColumn, AFDate, yDate, _
                                       xRow, i当専任, i当委託, j, Buf, kkk, ttt4, ttt5, ttt8, ttt9)
        Next k

        '専任職員
        s専任委託 = "*専任*"
        i当 = WorksheetFunction.CountIf(Ws.Cells(5, xColumn).Resize(iMember), "*当*")
        n = 2
        For k = i当 + 1 To 5
            Call Sh1_6088スケジュール表に当直を計算(Ws, n, s専任委託, MaxRow, xColumn, AFDate, yDate, _
                                       xRow, i当専任, i当委託, j, Buf, kkk, ttt4, ttt5, ttt8, ttt9)
        Next k

        '委託職員
        s専任委託 = "*委託*"
        i当 = WorksheetFunction.CountIf(Ws.Cells(5, xColumn).Resize(iMember), "*当*")
        n = 2
        For k = i当 + 1 To 5
            Call Sh1_6088スケジュール表に当直を計算(Ws, n, s専任委託, MaxRow, xColumn, AFDate, yDate, _
                                       xRow, i当専任, i当委託, j, Buf, kkk, ttt4, ttt5, ttt8, ttt9)
        Next k

        Call Sh1_44スケジュール表に当直を記入当日の予備動作(xColumn)
    Next xColumn

    '   セルに書き込んだ数字をクリアする
'    Ws.Cells(5, "AA").Resize(iMember, 72).SpecialCells(xlCellTypeConstants, 1).ClearContents
End Sub

'call>>(Ws, n, s専任委託, MaxRow, xColumn, AFDate, yDate, xRow, i当専任, i当委託, j, Buf, kkk, ttt4, ttt5, ttt8, ttt9)
Private Sub Sh1_6088スケジュール表に当直を計算(ByRef Ws As Worksheet, ByRef n As Long, ByRef s専任委託 As String, ByRef MaxRow As Long, _

                                  ByRef xColumn As Long, ByRef AFDate As Date, ByRef yDate As Date, ByRef xRow As Long, _
                                  ByRef i当専任 As Long, ByRef i当委託 As Long, ByRef j As Long, ByRef Buf As Variant, ByRef kkk As Long, _
                                  ByRef ttt4 As Long, ByRef ttt5 As Long, ByRef ttt8 As Long, ByRef ttt9 As Long)

    kkk = 0  '当直間隔  = Buf
    ttt4 = 999    'スケジュールしている月の当直数
    ttt8 = 999    '前月の当直数 +(有れば)前前月の当直数

    For j = MaxRow To 5 Step -1
        ttt9 = Ws.Cells(j, "H").Value + Ws.Cells(j, "N").Value + Ws.Cells(j, "T").Value + _
               Ws.Cells(j, "I").Value + Ws.Cells(j, "O").Value + Ws.Cells(j, "U").Value

        If Month(AFDate) = Month(yDate) Then
            ttt5 = Ws.Cells(j, "N").Value + Ws.Cells(j, "O").Value
        Else
            ttt5 = Ws.Cells(j, "T").Value + Ws.Cells(j, "U").Value
        End If

        Buf = Ws.Cells(j, xColumn).Value
        If Buf Like "*当*" Then
            Ws.Cells(j, xColumn).Value = "当直"
        ElseIf Buf Like "*休*" Then
        ElseIf Buf = 1 Then
        ElseIf Not (Ws.Cells(j, "C").Value Like s専任委託) Then
        ElseIf Ws.Cells(j, "E").Value > Ws.Cells(3, xColumn).Value Then
        ElseIf Ws.Cells(j, "F").Value < Ws.Cells(3, xColumn).Value And Ws.Cells(j, "F").Value <> "" Then
        ElseIf Buf = "" Then
            If kkk <> 999 Then
                xRow = j
                kkk = 999
            Else
                If Rnd > 0.67 Then
                    xRow = j
                End If
            End If
        ElseIf Buf >= n And kkk <> 999 Then
            If ttt4 > ttt5 Then
                xRow = j
                kkk = Buf
                ttt4 = ttt5
                ttt8 = ttt9
            ElseIf ttt4 = ttt5 Then
                If ttt8 > ttt9 Then
                    xRow = j
                    kkk = Buf
                    ttt4 = ttt5
                    ttt8 = ttt9
                ElseIf ttt8 = ttt9 Then
                    If kkk < Buf Then
                        xRow = j
                        kkk = Buf
                        ttt4 = ttt5
                        ttt8 = ttt9
                    ElseIf kkk = Buf Then
                        If Rnd > 0.67 Then
                            xRow = j
                        End If
                    End If
                End If
            End If
        End If
    Next j

    If kkk >= 2 Then
        If Ws.Cells(xRow, "C").Value Like "*委*" Then
'            Ws.Cells(xRow, xColumn).Value = "委当直"
            Ws.Cells(xRow, xColumn).Value = "当直"
            i当委託 = i当委託 + 1
        Else
            Ws.Cells(xRow, xColumn).Value = "当直"
            i当専任 = i当専任 + 1
        End If
    End If
End Sub

' "当直"を中央棟担当、入院棟担当、防災担当に振り分ける
Sub Sh1_6当直を中央棟担当_入院棟担当_防災担当に振り分ける()

    Dim i As Long, j As Long, k As Long, n As Long
    Dim xRow As Long, MaxRow As Long
    Dim Ws As Worksheet, xRange As Range
    Dim sColumn As Long, eColumn As Long, xColumn As Long
    Dim iMember As Long, Buf As String
    Dim i中央棟 As Long, i入院棟 As Long, i防災 As Long
    Dim Buf1, Buf2
    Dim myDic As Object, myDicItems As Variant

    Set myDic = CreateObject("Scripting.Dictionary")
    Set Ws = Sheets("Sheet1")
    MaxRow = Ws.Range("B" & Rows.Count).End(xlUp).Row
    iMember = MaxRow - 4

    '当月、来月の中央棟担当、入院棟担当、防災担当をクリアする
    Ws.Cells(5, "Q").Resize(iMember, 3).Value = 0
    Ws.Cells(5, "W").Resize(iMember, 3).Value = 0

    Application.ScreenUpdating = False
    For xColumn = Cells(3, "AF").Column To Cells(3, "CO").Column
        If Month(Ws.Cells(3, xColumn).Value) = Month(Ws.Cells(3, "AF").Value) Then
            sColumn = 14
        Else
            sColumn = 20
        End If
        myDic.removeall
        myDic("当中") = 3
        myDic("当入") = 1
        myDic("当防") = 1

        For xRow = 5 To MaxRow
            Buf = Ws.Cells(xRow, xColumn).Value
            If Buf Like "*当*" Then
                If Ws.Cells(xRow, "D").Value Like "*責任*" And myDic("当中") > 0 Then
                    If myDic("当中") > 0 Then
                        Ws.Cells(xRow, xColumn).Value = "当中"
                        Ws.Cells(xRow, sColumn + 3).Value = Ws.Cells(xRow, sColumn + 3).Value + 1
                        myDic("当中") = myDic("当中") - 1
                    End If
                End If
            End If
        Next xRow

        For xRow = 5 To MaxRow
            Buf = Ws.Cells(xRow, xColumn).Value
            If Buf Like "*当*" And Buf <> "当中" Then
                If (Ws.Cells(xRow, "D").Value Like "*中央*" Or Ws.Cells(xRow, "D").Value Like "*責任*") And myDic("当中") > 0 Then
                    Ws.Cells(xRow, xColumn).Value = "当中"
                    Ws.Cells(xRow, sColumn + 3).Value = Ws.Cells(xRow, sColumn + 3).Value + 1
                    myDic("当中") = myDic("当中") - 1
                ElseIf Ws.Cells(xRow, "D").Value Like "*入院*" And myDic("当入") > 0 Then
                    Ws.Cells(xRow, xColumn).Value = "当入"
                    Ws.Cells(xRow, sColumn + 4).Value = Ws.Cells(xRow, sColumn + 4).Value + 1
                    myDic("当入") = myDic("当入") - 1
                Else
                    myDic(xRow) = xRow _
                                & "|" & Ws.Cells(xRow, "K").Value + Ws.Cells(xRow, "Q").Value + Ws.Cells(xRow, "W").Value _
                                & "|" & Ws.Cells(xRow, "L").Value + Ws.Cells(xRow, "R").Value + Ws.Cells(xRow, "X").Value _
                                & "|" & Ws.Cells(xRow, "M").Value + Ws.Cells(xRow, "S").Value + Ws.Cells(xRow, "Y").Value
                End If
            End If
        Next xRow

        myDicItems = myDic.items
        For j = 0 To 30
            For i = 3 To UBound(myDicItems)
                Buf1 = myDicItems(i)
                Buf2 = Split(Buf1, "|")
                If Buf2(1) = j And myDic("当中") > 0 Then
                    Ws.Cells(Buf2(0), xColumn).Value = "当中"
                    Ws.Cells(Buf2(0), sColumn + 3).Value = Ws.Cells(Buf2(0), sColumn + 3).Value + 1
                    myDic("当中") = myDic("当中") - 1
                    myDicItems(i) = "99|99|99|99"
                End If
            Next i
            For i = 3 To UBound(myDicItems)
                Buf1 = myDicItems(i)
                Buf2 = Split(Buf1, "|")
                If Buf2(2) = j And myDic("当入") > 0 Then
                    Ws.Cells(Buf2(0), xColumn).Value = "当入"
                    Ws.Cells(Buf2(0), sColumn + 4).Value = Ws.Cells(Buf2(0), sColumn + 4).Value + 1
                    myDic("当入") = myDic("当入") - 1
                    myDicItems(i) = "99|99|99|99"
                End If
            Next i
            For i = UBound(myDicItems) To 3 Step -1
                Buf1 = myDicItems(i)
                Buf2 = Split(Buf1, "|")
                If Buf2(3) = j And myDic("当防") > 0 Then
                    Ws.Cells(Buf2(0), xColumn).Value = "当防"
                    Ws.Cells(Buf2(0), sColumn + 5).Value = Ws.Cells(Buf2(0), sColumn + 5).Value + 1
                    myDic("当防") = myDic("当防") - 1
                    myDicItems(i) = "99|99|99|99"
                End If
            Next i
        Next j
    Next xColumn
End Sub

'''スケジュール表には、前月末5日、当月、来月の日付けがある
Private Sub Sh1_44スケジュール表に当直を記入当日の予備動作(ByVal ssColumn As Long)

    Dim i As Long, j As Long, k As Long, n As Long
    Dim xRow As Long, MaxRow As Long, iMember As Long
    Dim Ws As Worksheet
    Dim myRange As Range, xRange As Range, regAA2 As Range
    Dim xDate As Date, myDate As Date, yDate As Date, AFDate As Date
    Dim AFColumn As Long, CLColumn As Long, xColumn As Long

    Call SetDimName_(Ws, MaxRow, iMember, AFColumn, CLColumn, regAA2, AFDate)

    Dim xAverage As Single
    Dim xSingle As Single, ySingle As Single
    Dim SumDate As Date

    AFDate = Ws.Cells(3, "AF").Value
    yDate = Ws.Cells(3, ssColumn).Value

    Application.ScreenUpdating = False
    For xRow = 5 To MaxRow
        '"1"の所は当直不可、"2"のところは他に当直可能者がいれば当直しない。
        If InStr(Cells(xRow, ssColumn), "当") Then

            If Month(AFDate) = Month(yDate) Then
                Ws.Cells(xRow, "N") = Ws.Cells(xRow, "N") + 1
            Else
                Ws.Cells(xRow, "T") = Ws.Cells(xRow, "T") + 1
            End If

            If IsNumeric(Cells(xRow, ssColumn + 1).Value) Then
                If Cells(xRow, ssColumn + 1).Value > 1 Then Cells(xRow, ssColumn + 1).Value = 1
            End If
            If IsNumeric(Cells(xRow, ssColumn + 2).Value) Then
                If Cells(xRow, ssColumn + 2).Value > 3 Then Cells(xRow, ssColumn + 2).Value = 3
            End If
            If IsNumeric(Cells(xRow, ssColumn + 3).Value) Then
                If Cells(xRow, ssColumn + 3).Value > 4 Then Cells(xRow, ssColumn + 3).Value = 4
            End If
            If IsNumeric(Cells(xRow, ssColumn + 4).Value) Then
                If Cells(xRow, ssColumn + 4).Value > 5 Then Cells(xRow, ssColumn + 4).Value = 5
            End If
            If IsNumeric(Cells(xRow, ssColumn + 5).Value) Then
                If Cells(xRow, ssColumn + 5).Value > 6 Then Cells(xRow, ssColumn + 5).Value = 6
            End If

            If Cells(xRow, ssColumn + 1).Value = "" Then Cells(xRow, ssColumn + 1).Value = 1
            If Cells(xRow, ssColumn + 2).Value = "" Then Cells(xRow, ssColumn + 2).Value = 3
            If Cells(xRow, ssColumn + 3).Value = "" Then Cells(xRow, ssColumn + 3).Value = 4
            If Cells(xRow, ssColumn + 4).Value = "" Then Cells(xRow, ssColumn + 4).Value = 5
            If Cells(xRow, ssColumn + 5).Value = "" Then Cells(xRow, ssColumn + 5).Value = 6

            '金土日の当直を月一回に限定したい・・・月によって金土日が5日の時が有り、当直メンバーが30人以上いないと実現しない。
            If Cells(4, ssColumn).Text = "金" Or Cells(4, ssColumn).Text = "土" Or Cells(4, ssColumn).Text = "日" Then
                If Month(AFDate) = Month(yDate) Then
                    xColumn = AFColumn + Day(DateSerial(Year(AFDate), Month(AFDate) + 1, 0))
                Else
                    xColumn = CLColumn
                End If
                For i = ssColumn + 7 To xColumn Step 7
                    If IsNumeric(Cells(xRow, i).Value) Then
                        If Cells(xRow, i).Value > 2 Then Cells(xRow, i).Value = 2
                    End If
                    If Cells(xRow, i).Value = "" Then Cells(xRow, i).Value = 2
                Next i
            End If
        End If
    Next xRow
End Sub

' 指定日以降のスケジュールをクリアする
Sub sh1_40指定日以降のスケジュールをクリアする()

    Dim Ws As Worksheet, myRange As Range, xRange As Range
    Dim regAA2 As Range
    Dim MaxRow As Long
    Dim xDate As Date

    Sheets("Sheet1").Select
    On Error Resume Next
    Set xRange = Application.InputBox(Prompt:=Date + 7 & "以降の日付けのあるセルを選択してください。", Type:=8)
    If Err.Number <> 0 Then Exit Sub
    On Error GoTo 0
    If xRange.Column < Cells(1, "AF").Column Then Exit Sub
    If xRange.Column > Cells(1, "CO").Column Then Exit Sub
    Columns(xRange.Column).Select
    xDate = Cells(3, xRange.Column).Value
    If xDate < Date + 7 Then
        MsgBox "今日から7日後までのスケジュールはクリアできません"
        Exit Sub
    End If
    If MsgBox(xDate & "以降のスケジュールを消して良いですか。", vbYesNo) <> vbYes Then Exit Sub

    Application.ScreenUpdating = False
    Set Ws = Sheets("Sheet1")
    MaxRow = Ws.Range("B" & Rows.Count).End(xlUp).Row
    Set regAA2 = Ws.Cells(2, "AA")
    Set myRange = regAA2.Offset(3, 5).Resize(MaxRow - 4, 67)

    For Each xRange In myRange
        If xRange.Font.ColorIndex <> 3 Then    '赤
            If Ws.Cells(3, xRange.Column) >= xDate Then
                xRange.ClearContents
            End If
        End If
    Next xRange
End Sub

'''スケジュール表には、前月末5日、当月、来月の日付けがある
Sub Sh1_4三ヶ月のスケジュール表に当直を記入の予備動作()

    Dim i As Long, j As Long, k As Long, n As Long
    Dim xRow As Long, MaxRow As Long, iMember As Long
    Dim Ws As Worksheet
    Dim myRange As Range, xRange As Range, regAA2 As Range
    Dim xDate As Date, myDate As Date, yDate As Date, AFDate As Date
    Dim AFColumn As Long, CLColumn As Long, xColumn As Long

    Call SetDimName_(Ws, MaxRow, iMember, AFColumn, CLColumn, regAA2, AFDate)

    Dim Buf As String
    Dim yColumn As Long

    Set myRange = regAA2.Offset(3).Resize(iMember, 67)

    Application.ScreenUpdating = False
    For j = myRange.Count To 1 Step -1
        Set xRange = myRange.Item(j)
        xColumn = xRange.Column
        Buf = xRange.Value
        '"1"の所は当直不可、"2"のところは他に当直可能者がいれば当直しない。
        If InStr(Buf, "当") Then
            If xRange.Offset(, 1).Value = "" Then xRange.Offset(, 1).Value = 1
            If xRange.Offset(, 2).Value = "" Then xRange.Offset(, 2).Value = 3
            If xRange.Offset(, 3).Value = "" Then xRange.Offset(, 3).Value = 4
            If xRange.Offset(, 4).Value = "" Then xRange.Offset(, 4).Value = 5
            If xRange.Offset(, 5).Value = "" Then xRange.Offset(, 5).Value = 6
            If xColumn > regAA2.Offset(, 5).Column Then
                If xRange.Offset(, -1).Value = "" Then xRange.Offset(, -1).Value = 1
                If xRange.Offset(, -2).Value = "" Then xRange.Offset(, -2).Value = 3
                If xRange.Offset(, -3).Value = "" Then xRange.Offset(, -3).Value = 4
            End If

            '金土日の当直を月一回に限定したい・・・月によって金土日が5日の時が有り、当直メンバーが30人以上いないと実現しない。
            If Cells(4, xColumn).Text = "金" Or Cells(4, xColumn).Text = "土" Or Cells(4, xColumn).Text = "日" Then
                xRow = xRange.Row
                If Month(AFDate) = Month(yDate) Then
                    yColumn = AFColumn + Day(DateSerial(Year(AFDate), Month(AFDate) + 1, 0))
                Else
                    yColumn = CLColumn
                End If
                For i = xColumn + 7 To yColumn Step 7
                    If IsNumeric(Cells(xRow, i).Value) Then
                        If Cells(xRow, i).Value > 2 Then Cells(xRow, i).Value = 2
                    End If
                    If Cells(xRow, i).Value = "" Then Cells(xRow, i).Value = 2
                Next i
                If Month(AFDate) = Month(yDate) Then
                    yColumn = AFColumn
                Else
                    yColumn = CLColumn - Day(DateSerial(Year(AFDate), Month(AFDate) + 2, 0))
                End If
                For i = xColumn - 7 To yColumn Step -7
                    If IsNumeric(Cells(xRow, i).Value) Then
                        If Cells(xRow, i).Value > 2 Then Cells(xRow, i).Value = 2
                    End If
                    If Cells(xRow, i).Value = "" Then Cells(xRow, i).Value = 2
                Next i
            End If
        ElseIf InStr(Buf, "休") Then
            If xRange.Offset(, -1).Value = "" Then xRange.Offset(, -1).Value = 1
        End If
    Next j

End Sub

Sub SetDimName_(ByRef Ws As Worksheet, ByRef MaxRow As Long, ByRef iMember As Long, ByRef AFColumn As Long, _

                ByRef CLColumn As Long, ByRef regAA2 As Range, ByRef AFDate As Date)
    Set Ws = Sheets("Sheet1")
    Set regAA2 = Ws.Cells(2, "AA")
    MaxRow = Ws.Range("B" & Rows.Count).End(xlUp).Row
    iMember = MaxRow - 4
    AFDate = Ws.Cells(3, "AF").Value
    AFColumn = Ws.Cells(3, "AF").Column
    CLColumn = Ws.Cells(3, Columns.Count).End(xlToLeft).Column
End Sub

Sub Sh1_02初日終了日で当直日数補正()

    Dim i As Long, j As Long, k As Long, n As Long
    Dim xRow As Long, MaxRow As Long, iMember As Long
    Dim Ws As Worksheet
    Dim myRange As Range, xRange As Range, regAA2 As Range
    Dim xDate As Date, myDate As Date, yDate As Date, AFDate As Date
    Dim AFColumn As Long, CLColumn As Long, xColumn As Long

    Call SetDimName_(Ws, MaxRow, iMember, AFColumn, CLColumn, regAA2, AFDate)

    Dim Buf As String
    Dim xAverage As Single

    Ws.Cells(5, "I").Resize(iMember).ClearContents
    Ws.Cells(5, "O").Resize(iMember).ClearContents
    Ws.Cells(5, "U").Resize(iMember).ClearContents

    For xRow = 5 To MaxRow
        If Ws.Cells(xRow, "F").Value <> "" Then
            yDate = Ws.Cells(xRow, "F").Value    'AFDate = 2/1
            If yDate >= DateSerial(Year(AFDate), Month(AFDate) + 2, 1) Then    '4/1
            ElseIf yDate >= DateSerial(Year(AFDate), Month(AFDate) + 1, 1) Then  '3/1
                Ws.Cells(xRow, "U") = 0
            ElseIf yDate >= DateSerial(Year(AFDate), Month(AFDate) - 0, 1) Then  '2/1
                Ws.Cells(xRow, "U") = 0
                Ws.Cells(xRow, "O") = 0
            Else
                Ws.Cells(xRow, "U") = 0
                Ws.Cells(xRow, "O") = 0
                Ws.Cells(xRow, "I") = 0
            End If
        End If

        '当直日数補正
        If Ws.Cells(xRow, "E").Value <> "" Then
            yDate = Ws.Cells(xRow, "E").Value
            If yDate < DateSerial(Year(AFDate), Month(AFDate) - 1, 1) Then
            ElseIf yDate < AFDate Then
                Ws.Cells(xRow, "I") = Day(yDate) - 1
            ElseIf yDate < DateSerial(Year(AFDate), Month(AFDate) + 1, 1) Then
                Ws.Cells(xRow, "I") = Day(DateSerial(Year(AFDate), Month(AFDate), 0))
                Ws.Cells(xRow, "O") = Day(yDate) - 1
            ElseIf yDate < DateSerial(Year(AFDate), Month(AFDate) + 2, 1) Then
                Ws.Cells(xRow, "I") = Day(DateSerial(Year(AFDate), Month(AFDate), 0))
                Ws.Cells(xRow, "O") = Day(DateSerial(Year(AFDate), Month(AFDate) + 1, 0))
                Ws.Cells(xRow, "U") = Day(yDate) - 1
            Else
                Ws.Cells(xRow, "I") = Day(DateSerial(Year(AFDate), Month(AFDate), 0))
                Ws.Cells(xRow, "O") = Day(DateSerial(Year(AFDate), Month(AFDate) + 1, 0))
                Ws.Cells(xRow, "U") = Day(DateSerial(Year(AFDate), Month(AFDate) + 2, 0))
            End If
        End If

        'Int(5 / (iMember - i + 1) * Ws.Cells(xRow, "I").Value + 0.5) の式の意味
        '一日の当直者数 ÷ メンバー人数 × 日数 ・・・整数四捨五入

        i = WorksheetFunction.Count(Ws.Cells(5, "I").Resize(iMember))
        If Ws.Cells(xRow, "I").Value > 0 Then
            Ws.Cells(xRow, "I").Value = Int(5 / (iMember - i + 1) * Ws.Cells(xRow, "I").Value + 0.5)
        End If

        i = WorksheetFunction.Count(Ws.Cells(5, "O").Resize(iMember))
        If Ws.Cells(xRow, "O").Value > 0 Then
            Ws.Cells(xRow, "O").Value = Int(5 / (iMember - i + 1) * Ws.Cells(xRow, "O").Value + 0.5)
        End If

        i = WorksheetFunction.Count(Ws.Cells(5, "U").Resize(iMember))
        If Ws.Cells(xRow, "U").Value > 0 Then
            Ws.Cells(xRow, "U").Value = Int(5 / (iMember - i + 1) * Ws.Cells(xRow, "U").Value + 0.5)
        End If

    Next xRow
End Sub

'''スケジュール表には、前月末5日、当月、来月の日付けがある
'''それを当月末5日、来月、来来月にする・・・実行日で見ると前月末5日、当月、来月になる

Sub Sh1_2前月末5日_当月_来月表を当月末5日_来月_来来月にする()

    Dim i As Long, j As Long, k As Long, n As Long
    Dim xRow As Long, MaxRow As Long, iMember As Long
    Dim Ws As Worksheet, xRange As Range, regAA2 As Range
    Dim xDate As Date, myDate As Date, yDate As Date, AFDate As Date
    Dim AFColumn As Long, CLColumn As Long, xColumn As Long

    Call SetDimName_(Ws, MaxRow, iMember, AFColumn, CLColumn, regAA2, AFDate)

    myDate = Date
    xDate = regAA2.Offset(, 5).Value
    xDate = DateSerial(Year(xDate), Month(xDate) + 1, 0)

    Application.ScreenUpdating = False
    If Not IsDate(regAA2.Value) Then
    ElseIf myDate <= xDate Then
        Exit Sub
    Else
        '日付けをずらす際に過去二月と過去一月の実績を記録
        Ws.Cells(5, "N").Resize(iMember, 12).Copy Ws.Cells(5, "H")

        i = Day(xDate)  'i, jには、その月の日数を入れている
        j = Day(DateSerial(Year(xDate), Month(xDate) + 2, 0))
        regAA2.Offset(, i).Resize(MaxRow, j + 5).Copy regAA2
        regAA2.Offset(, j + 5).Resize(MaxRow, 67 - j).ClearContents
        regAA2.Offset(, j + 5).Resize(MaxRow, 67 - j).Font.ColorIndex = 1
    End If

    j = Day(DateSerial(Year(xDate), Month(xDate) + 2, 0))
    regAA2.Resize(3, 67).Interior.ColorIndex = 35
    regAA2.Offset(, 5).Resize(2, j).Interior.ColorIndex = 40

    xDate = xDate - 4
    For i = 0 To 66
        If xDate + i > DateSerial(Year(xDate), Month(xDate) + 3, 0) Then Exit For
        regAA2.Offset(, i).Value = xDate + i
        regAA2.Offset(1, i).Value = xDate + i
        regAA2.Offset(2, i).Value = xDate + i
        If Format(xDate + i, "aaa") = "土" Then regAA2.Offset(2, i).Interior.ColorIndex = 6
        If Format(xDate + i, "aaa") = "日" Then regAA2.Offset(2, i).Interior.ColorIndex = 3
    Next i
End Sub

(トラ) 2017/02/20(月) 13:36


すみません、下のコードのコメントマークを消して実行してください。

    '   セルに書き込んだ数字をクリアする
'    Ws.Cells(5, "AA").Resize(iMember, 72).SpecialCells(xlCellTypeConstants, 1).ClearContents

(トラ) 2017/02/20(月) 16:19


トラ様へ
返事遅れてすみません。
コード表ありがとうございます。
報告するの忘れました、すみません
Sub Sh1_1見出しと罫線のセット() のついては、とても見えやすいです。
質問ですが、右の緑の表は何でしょうか?

投稿してくれたコードを実行してみたですけど、実行時エラーを出てしまってどうしたらいいでしょうか、、

デバッグボタン押してみたら
黄色マーカーでregAA2.Offset(, i).Value = xDate + i
と出ました。

質問ですが、
やり方は、マクロボタンを押してマクロ名内(A_Main)を入力し編集ボタンを押し、投稿してくれたコードを貼り付け実行すればいいでしょうか?

VBA初心者ですみません。
でもコード見て勉強になります。

迷惑をお掛け申し訳がありません。本当に反省しております、すみません。
お手数をおかけしますが宜しくお願い致します。
(SinNeo) 2017/02/21(火) 00:50


SinNeoさんへ

質問ですが、右の緑の表は何でしょうか?
・・・日付けと、その下のセルに当直予定が造られます。

エラーの件ですが次のように変更してください。

Sub Sh1_2前月末5日_当月_来月表を当月末5日_来月_来来月にする()

    Dim i As Long, j As Long, k As Long, n As Long
    Dim xRow As Long, MaxRow As Long, iMember As Long
    Dim Ws As Worksheet, xRange As Range, regAA2 As Range
    Dim xDate As Date, myDate As Date, yDate As Date, AFDate As Date
    Dim AFColumn As Long, CLColumn As Long, xColumn As Long

    Call SetDimName_(Ws, MaxRow, iMember, AFColumn, CLColumn, regAA2, AFDate)

    myDate = Date
    xDate = regAA2.Offset(, 5).Value
    xDate = DateSerial(Year(xDate), Month(xDate) + 1, 0)

上のコードの下三行を下に記す二行に替えてください。
  myDate = Date

    xDate = DateSerial(Year(Date), Month(Date), 0)
に変更してください。

それから資格ですが、専門の欄に
中央棟、責任者、入院棟と入れてください。
とりあえず空欄でも問題ないです。
資格による、当直の振り分けには解決できない問題が有ります。
一応の結果がでてからまた話し合いましょう
(トラ) 2017/02/21(火) 07:59


トラ様へ

ありがとうございます。
投稿してくれたコードを修正し実行出来ました。
素晴らしいです、、言葉がないです、、

そうですね、ありがとうございます、話し合いましょう。

すみませんが、■の部分は入力した方がいいでしょうか?

お手数ですが、宜しくお願い致します。
(SinNeo) 2017/02/21(火) 11:55


SinNeoさんへ

質問形式になっている投稿には、全て答えてください。

コードを投稿されたら、それがエラーがでないか、結果を詳細に調べて意図と違うところがないかを
調べて、すぐに報告してください。
問題点を指摘するのは貴方です。

日がたつと自分でもどういう意図でコードを書いたのか解らなくなります。

一応の結果がでたようなので、
本番形式のデータで試してください。
入力が必要なのは
名前 所属 専門 初日 終了日
過去一月の当直数
2月1日〜3月31日の予定を消して
2月24日〜2月28日の実際の当直状況を記入

これで、3月以降実際に使用するスケジュールが出来るはずです。

Sub B_Clearは、実行しましたか
まともに動きましたか

これから書くコードは、("Sheet1")のシートモジュールに貼り付けてください。
そして、3月のスケジュール表のセルをクリックしてください。
感想を聞かせてください。

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    Dim myOLEList As OLEObject
    Dim myOLEListObj As Object
    Dim myWidth As Long
    Dim myArray
    Dim i As Long, j As Long, k As Long, n As Long
    Dim Buf As String
    Dim xRange As Range

    On Error Resume Next
    OLEObjects("myListBox1").Delete
    On Error GoTo 0

    If Target.Count <> 1 Then Exit Sub
    i = Cells(Rows.Count, "B").End(xlUp).Row
    If i = 4 Then Exit Sub
    Set xRange = Cells(5, "AA").Resize(i - 4, 67)
    If Intersect(Target, xRange) Is Nothing Then Exit Sub
    If Cells(3, Target.Column).Value < Date Then Exit Sub

    Application.EnableEvents = False
    'リストボックス作成
    With Target.Offset(1)
        Set myOLEList = OLEObjects.Add("Forms.ListBox.1", _
                                       Left:=.Left, Top:=.Top, Width:=200, _
                                       Height:=9 * .Height)
    End With
    myOLEList.Name = "myListBox1"
        Buf = "当日以降の予定入力," & _
              "[代休] 代休のため," & _
              "[有休] 有給休暇で休み," & _
              "[出休] 出張のため," & _
              "[公休] 公休で休み," & _
              "[当希] 当直希望," & _
              "[■休] 例外処理のために休み," & _
              "[■当] 例外処理のため当直," & _
              "[取消] セルのクリア"
    myArray = Split(Buf, ",")

    '作成したリストボックスのオブジェクト
    Set myOLEListObj = myOLEList.Object
    With myOLEListObj
        .List = myArray
        .Font.Size = 12
    End With

    'Selectが必須
    ActiveSheet.Select

    Set myOLEListObj = Nothing
    Set myOLEList = Nothing
    Application.EnableEvents = True
End Sub

Private Sub myListBox1_Click()
'上のコードで作成されたリストボックスの名前を使う"myListBox1"_Click()

    Dim Buf
    Dim xRange As Range

    If myListBox1.ListIndex <= 0 Then Exit Sub
    Application.EnableEvents = False
    Buf = myListBox1.List(myListBox1.ListIndex)

    If Mid(Buf, 2, 2) Like "*当*" Then
        If ActiveCell.Offset(, 1).Value Like "*当*" Or ActiveCell.Offset(, -1).Value Like "*当*" Then
            MsgBox "連続当直は避けてください"
            Exit Sub
        End If
        If ActiveCell.Offset(, 1).Value Like "*休*" Then
            MsgBox "休日直前は避けてください"
            Exit Sub
        End If
    End If
    If Mid(Buf, 2, 2) Like "*休*" Then
        If ActiveCell.Offset(, -1).Value Like "*当*" Then
            MsgBox "当直直後は避けてください"
            Exit Sub
        End If
    End If

    If Mid(Buf, 2, 2) <> "取消" Then
        ActiveCell.Value = Mid(Buf, 2, 2)
        ActiveCell.Font.ColorIndex = 3  '赤
    Else
        ActiveCell.Value = ""
        ActiveCell.Font.ColorIndex = 1
    End If
    For Each xRange In ActiveCell.Offset(, 1).Resize(, 62)
        If xRange.Font.ColorIndex <> 3 Then   '赤
            xRange.ClearContents
        End If
    Next xRange

    Application.EnableEvents = True
    OLEObjects("myListBox1").Delete
End Sub

資格による、当直の振り分けには解決できない問題が有ります。
これはエラーがでるとかの問題ではないので、そのままで良ければ修正無で
(トラ) 2017/02/21(火) 13:37


すみません、プログラムのミスです。

Sub Sh1_2前月末5日_当月_来月表を当月末5日_来月_来来月にする()

    Dim i As Long, j As Long, k As Long, n As Long
    Dim xRow As Long, MaxRow As Long, iMember As Long
    Dim Ws As Worksheet, xRange As Range, regAA2 As Range
    Dim xDate As Date, myDate As Date, yDate As Date, AFDate As Date
    Dim AFColumn As Long, CLColumn As Long, xColumn As Long

    Call SetDimName_(Ws, MaxRow, iMember, AFColumn, CLColumn, regAA2, AFDate)

    myDate = Date

    xDate = DateSerial(Year(Date), Month(Date), 0)・・・今日変更した分
上のコードの下一行(今日変更した分)を下に記す六行に替えてください。 
  If regAA2.Offset(, 5).Value <> "" Then
        xDate = regAA2.Offset(, 5).Value
        xDate = DateSerial(Year(xDate), Month(xDate) + 1, 0)
    Else
        xDate = DateSerial(Year(Date), Month(Date), 0)
    End If
に変更してください。

それから、イベントプログラム追加により次のように変更してください。

Sub A_Main()

    Application.EnableEvents = False
    Randomize

    Call Sh1_2前月末5日_当月_来月表を当月末5日_来月_来来月にする

    Call Sh1_02初日終了日で当直日数補正

    Call Sh1_4三ヶ月のスケジュール表に当直を記入の予備動作

    Call Sh1_6スケジュール表に当直を計算

    Call Sh1_6当直を中央棟担当_入院棟担当_防災担当に振り分ける
    Application.EnableEvents = True
End Sub

'人員の増減が有った時に実行、当直数のばらつきが大きい時があるのでその時実行
Sub B_Clear()

    Application.EnableEvents = False
    Call sh1_40指定日以降のスケジュールをクリアする
    Application.EnableEvents = True
End Sub
(トラ) 2017/02/21(火) 14:41

 >トラ さん
 なんだか、どえらいことになってますね(^^♪
 コーディング作業、ずいぶん、しんどそうですね。お疲れ様ですm(_ _)m
 サンプルファイルを何処かに置いてもらえませんか?
 とても追えないぐらい、ボリューミーなので。

 ・条件をかいくぐって、最終的に、その日の当直に選ばれた5人が全員、
 【電気の資格者】担当だとややこしいことになる。

 ・また、専任職員が40人、委託職員が40人で、計80人の場合に、
 80人全員が【電気の資格者】だと、矛盾してエラーになる。
 なぜなら、当直(電気3人、空調1人、水道1人の計5人)の
 空調担当、水道担当が決まらない為。

 ・仮のはなしですが、
 当直表を作成する月の日数が、31日だとすると、
 毎日当直があり、当直5人のうち3人が電気担当なので、
 その月は、電気担当として当直に入る人が、31×3で、93人となる。
 電気担当であるA〜Lの12人すべてが、当直希望数が8回だとして、
 希望通り、当直に入ろうとしても、
 93÷8=11余り5になるから、12人すべて当直に希望通りつけない。
 【電気の資格者】の人数と【その電気の資格者の当直希望数】
 の関係を整理しないといけないような…。

 ・【電気の資格者】をどの条件よりも先に、当直表に書き込むことにな
 ると思われる。コードの大幅な見直しが必要。詰めて考えてませんが…。

                                      (通りすがり)ことマリオより

(マリオ) 2017/02/21(火) 15:00


マリオ様 いつも気にかけて頂いてありがとうございます。

前のスレで、名前を出して申し訳ないと思っています。

・条件をかいくぐって、最終的に、その日の当直に選ばれた5人が全員、
【電気の資格者】担当だとややこしいことになる。
・・・・・
コードの大幅な見直しが必要

そのような事をSinNeoさんと話し合いたいと思ったのですが
まだ他の事で考えが回らないみたいなので。
とりあえず残りは他の担当に振り分けてエラーは出ないようになっています。

サンプルファイルを何処かに置いてもらえませんか?
すみません、そういうことはしていません。

(トラ) 2017/02/21(火) 20:05


マリオ様へ

サンプルファイルを何処かに置く代わりに・・・

まず、標準モジュールの一つ目に
Sub A_Main()
Sub B_Clear()

それと下のコードを貼り付けてください。最初にアップしたものと項目名などが違います。

Sub Sh1_1最初に見出しと罫線のセット()

    Dim sss, i, j, k
    Dim Ws As Worksheet, regAA2 As Range
    Dim xDate As Date

    Sheets("Sheet1").Select
    Rows(2).Resize(3).HorizontalAlignment = xlCenter

    Cells(3, "H").Resize(, 6).Merge
    Cells(3, "N").Resize(, 6).Merge
    Cells(3, "T").Resize(, 6).Merge
    Cells(3, "H").Value = "過去一月の"
    Cells(3, "N").Value = "当月の"
    Cells(3, "T").Value = "来月の"
    sss = "名前,所属,専門,初日,終了日,,当直数,日数補正,土日,中央棟,入院棟,防災,当直数,日数補正,土日,中央棟,入院棟,防災,当直数,日数補正,土日,中央棟,入院棟,防災"
    sss = Split(sss, ",")
    Cells(4, "B").Resize(, UBound(sss) + 1).Value = sss
    Cells(5, "B").Resize(22).Value = "名前1to22"
    Cells(5, "C").Resize(16).Value = "専任"
    Cells(21, "C").Resize(6).Value = "委託"
    Cells(5, "H").Resize(22).Value = 7
    Cells(5, "G").Resize(22).Formula = "=SUM(H5,N5,T5)"

    Rows(21).Resize(6, 100).Interior.ColorIndex = 6

    Set regAA2 = Cells(2, "AA").Resize(42, 67)
    regAA2.Resize(1).NumberFormatLocal = "M"
    regAA2.Resize(1).Offset(1).NumberFormatLocal = "D"
    regAA2.Resize(1).Offset(2).NumberFormatLocal = "aaa"

    Cells(3, "H").Resize(41, 18).Borders.LineStyle = True
    Cells(4, "B").Resize(40, 5).Borders.LineStyle = True
    regAA2.Borders.LineStyle = True

    regAA2.ColumnWidth = 3.5
    regAA2.Resize(3, 67).Interior.ColorIndex = 35
    j = Day(DateSerial(Year(Date), Month(Date) + 1, 0))
    regAA2.Offset(, 5).Resize(2, j).Interior.ColorIndex = 40

    Set regAA2 = regAA2.Resize(1, 1)
    xDate = DateSerial(Year(Date), Month(Date), 0) - 4
    For i = 0 To 66
        If xDate + i > DateSerial(Year(xDate), Month(xDate) + 3, 0) Then Exit For
        regAA2.Offset(, i).Value = xDate + i
        regAA2.Offset(1, i).Value = xDate + i
        regAA2.Offset(2, i).Value = xDate + i
        If Format(xDate + i, "aaa") = "土" Then regAA2.Offset(2, i).Interior.ColorIndex = 6
        If Format(xDate + i, "aaa") = "日" Then regAA2.Offset(2, i).Interior.ColorIndex = 3
    Next i
End Sub

二つ目の標準モジュールに
Option Explicit
Option Private Module より下のコードを貼り付けてください。
コードのミスは修正してください。

("Sheet1")のシートモジュールに最後にアップしたコードを貼り付けてください。

これを書き込んだ後、
このウェブページから新規ブックにコードを貼り付け
想定どおり動作するか試して見ます。
想定とおり動作しなかったらまた何か書きます。
(トラ) 2017/02/22(水) 09:26


 >トラさん

 次の手順でファイルを作成してみました。
 ざっくりで、いいんで、こんな感じでいいでしょうか?

 ******* Module3に記述するコード *********************************
 ★次の1個のプロシージャを記述
 Sub Sh1_1最初に見出しと罫線のセット()
 *****************************************************************
 _
 _
 ******* Module1に記述するコード *********************************
 ★次の2個のプロシージャを記述
 Sub A_Main()'Application.EnableEvents処理で挟み込んだ方
 Sub B_Clear()'Application.EnableEvents処理で挟み込んだ方
 *****************************************************************
 _
 _
 ******* Module2に記述するコード *********************************
 Option Explicit
 Option Private Module
 を書いた後に、次の★9個のプロシージャを記述

 Sub Sh1_2前月末5日_当月_来月表を当月末5日_来月_来来月にする
 Sub Sh1_02初日終了日で当直日数補正
 Sub Sh1_4三ヶ月のスケジュール表に当直を記入の予備動作
 Sub Sh1_6スケジュール表に当直を計算
 Sub Sh1_6当直を中央棟担当_入院棟担当_防災担当に振り分ける
 Private Sub Sh1_6088スケジュール表に当直を計算
 Private Sub Sh1_44スケジュール表に当直を記入当日の予備動作(ByVal
 Sub sh1_40指定日以降のスケジュールをクリアする()
 Sub SetDimName_(ByRef
 *****************************************************************
 ★修正箇所
 Sub Sh1_2前月末5日_当月_来月表を当月末5日_来月_来来月にする()
 において、
    '〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓
    '修正前
     'myDate = Date
     'xDate = regAA2.Offset(, 5).Value
     'xDate = DateSerial(Year(xDate), Month(xDate) + 1, 0)
    '〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓
    '修正後
     myDate = Date
     xDate = DateSerial(Year(Date), Month(Date), 0)
    '〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓
 _
 _
 ******* Sheet1に記述するコード *********************************
 次の★2個のプロシージャを記述
 Private Sub Worksheet_SelectionChange(ByVal
 Private Sub myListBox1_Click
 *****************************************************************
(マリオ) 2017/02/22(水) 17:10

 >トラさん
  「シート名:Sheet1」があることを確認後に、
 【Sub Sh1_1最初に見出しと罫線のセット()】を実行して表を作成
 しましたら、
 ★21〜26行が黄色く塗りつぶされました。
 ★また、G5:H26の各セルに「7」が入力されました。
 これで、いいのでしょうか?

 ★こちらで入力(下準備)するのは、B〜F列だけでしょうか?
 B列は名前、C列は専門または委託ですね。
 ★D列は何でしょうか?、
 ★E列、D列は、2行目のAA列以降に記述されているすべての日付で、
 当直可能なら空白でいいでしょうか?

 下準備が終わったら、【Sub A_Main()】を実行すればいいのでしょうか?
(マリオ) 2017/02/22(水) 17:11

 マリオ様へ
 もう一度修正しています。
    '〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓
    '修正前
     'myDate = Date
     'xDate = regAA2.Offset(, 5).Value
     'xDate = DateSerial(Year(xDate), Month(xDate) + 1, 0)
    '〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓
    '修正後
     myDate = Date
     If regAA2.Offset(, 5).Value <> "" Then
        xDate = regAA2.Offset(, 5).Value
        xDate = DateSerial(Year(xDate), Month(xDate) + 1, 0)
    Else
        xDate = DateSerial(Year(Date), Month(Date), 0)
    End If
    '〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓

 '   セルに書き込んだ数字をクリアする
 '    Ws.Cells(5, "AA").Resize(iMember, 72).SpecialCells(xlCellTypeConstants, 1).ClearContents 
 上記のコメントを消し実行するようにしてください。
 コメントにしたままだと、どのようにして当直者を選考したのかの経緯が見えます。

 ★21〜26行が黄色く塗りつぶされました。

 ★また、G5:H26の各セルに「7」が入力されました。
 これはそのままで良いです。
 色は、専門と委託を区別するためでなくても良いです。
 7は、22人で1月の平均当直回数です。G列の計算式は、三ヶ月の合計当直回数です。
 確認のためです。
 ★D列は何でしょうか?
 電気の資格者に替わる物で、責任者、中央棟、入院棟のどれかの文字を入力、全部空白でも良い
 ★E列、F列は、2行目のAA列以降に記述されているすべての日付で、
 当直可能なら空白でいいでしょうか?
 空白で良いです。日付けを入れるなら3月以降が良いです。

 

これで実行してください。
(トラ) 2017/02/22(水) 19:16


話変わってすみません。

トラ様へ
返信遅れて申し訳がありません。
すみません、いつも気にかけて頂いてありがとうございます。

投稿してくれたコードを修正し実行出来ました。とてもいいです。
勉強になります。

『Sub B_Clear』
素晴らしいです。分かりやすくて選択し自動的に削除するのとてもやりやすいです。

『("Sheet1")のシートモジュール』
入力しなくてもリフトボックスから選べるって素晴らしいですが、
Excel2010はリフトボックスから選択することが出来ますが、Excel2013はリフトボックスから選択することが出来ないです。
どうしたらいいでしょうか。

質問については、しばらくお持ち下さい。(すみませんが、中途半端で突然注文するの良くないのは、承知しておりますが、条件相談し追加する可能性があります。迷惑をかけて申し訳がありません。)
明日か明後日投稿予定です。(早ければ今日)

よろしくお願い致します。

マリオ様へ
あの時は、本当に反省しております。迷惑をかけて申し訳がありませんでした。
作ってくれたファイル本当にありがとうございます。勉強になります。
(SinNeo) 2017/02/23(木) 00:10


解決できない問題とは、マリオ様の指摘の有った
・条件をかいくぐって、最終的に、その日の当直に選ばれた5人が全員、
【電気の資格者】担当だとややこしいことになる・・・の投稿のことです。

Excel2010はリフトボックスから選択することが出来ますが、Excel2013はリフトボックスから選択することが出来ないです

私は2013を所有していないので原因究明が出来ないのですが
デザインモードになっているなんてことは無いですよね。
どなたか原因の解る方の書き込みが有ると良いですね。

このコードをそのままコピー貼り付けして、
どの段階で止まるのかを説明して
2010では実行できるけど、2013では実効出来ない。・・・と新しく質問を建てるしかないです。

解決したらその方法を私にも教えてください。
(トラ) 2017/02/23(木) 10:21


 > トラさん
 まだ、確認しきれてないところが、多々ある状態ですが…。 

 >Excel2010はリフトボックスから選択することが出来ますが、Excel2013はリフトボックスから選択することが出来ないです 

 私もExcel2013ですが、リストボックスから選択できません。今日の日付以降の表のセルを左クリック
 したときに、リストボックス自体は表示されるのですが…。あと、右側のスライドバーも動かせません。
 ActiveXコントロールは、不具合がいろいろ、見つかってるとかいないとか‥。 

 ActiveXコントロールのリストボックスを使用していますが、
 ★フォームコントロールのリストボックスにして、コードを書き換えられませんでしょうか?

 ★フォームコントロールのリストボックスを使用するなら、Private Sub myListBox1_Click()
 のところは、Moduleに【適当なプロシージャ名】を付けてコードを書くことになろうかと思います。
 (フォームコントロールのリストボックスに、【適当なプロシージャ名】のマクロ登録を★OnActionで行う)

 >デザインモードになっているなんてことは無いですよね。 
 ないです。

                   ■使用環境: Window10(64bit), Excel2013(32bit)

 *********************************************************
 >色は、専門と委託を区別するためでなくても良いです。
 Rows(21).Resize(6, 100).Interior.ColorIndex = 6
 のコードで、黄色く色塗りしてるんですかね。
 CQ列まででなく、CV列まで黄色く色塗りしているのは、
 CS〜CV列も作業列として使用しているからなんでしょうか?

 単に、専門と委託を区別するためなら、
 条件付き書式
 (C列の5〜C列最終列までのC列で、文字列が委託なら特定範囲を色塗り) 
 で色塗りした方がいいと思います。
 (特定範囲:とりあえず、B列〜2行目で判断される日付の最終列まで)

 例えば、当直回数とかをフィルコピーしたとき、色変わっちゃいますから。 
 初期設定の7じゃなくて、すべて手作業で8にしたいときとか

(マリオ) 2017/02/23(木) 11:01


 マリオさんへ

 ★フォームコントロールのリストボックスにして、コードを書き換えられませんでしょうか?
 ユーザーフォームで無く、普通はマクロの登録とかするフォームですよね。
 可能です。時間をもらえますか

 フォームのリストは、文字の大きさが変えれません(文字が小さい)。

 ユーザーフォームは、使用者にユーザーフォームを作ってもらう必用があるし
 表示場所の設定が面倒・ウィンドウ枠の固定があると特に面倒

 上記の理由でActiveXコントロールを使用していましたが、これからは止めようと思います。
 (本当は不具合の理由が解れば使用したい。)
 
 ★色は深く考ええずにつけていました。
 CS〜CV列も作業列として・・・CP列以降セルがクリアされる可能性が有ます。

 ★SinNeoさんへ
 『Sub B_Clear』は、文字が赤のものは、削除しない仕様になっています。
 イベントで入力した文字は赤にしています。
 今は2月ですので、2月3月のスケジュールですが 
 「今日」が3月1日に成ると自動的に3月4月のスケジュールになる様にしています。

(トラ) 2017/02/23(木) 14:17


また、間違いがありました。

 Sub Sh1_4三ヶ月のスケジュール表に当直を記入の予備動作() において、
    '〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓
    '修正前
     '金土日の当直を月一回に限定したい・・・月によって金土日が5日の時が有り、当直メンバーが30人以上いないと実現しない。
  If Cells(4, xColumn).Text = "金" Or Cells(4, xColumn).Text = "土" Or Cells(4, xColumn).Text = "日" Then
    '〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓
    '修正後
     '金土日の当直を月一回に限定したい・・・月によって金土日が5日の時が有り、当直メンバーが30人以上いないと実現しない。
  yDate = Ws.Cells(3, xColumn).Value
     If Ws.Cells(4, xColumn).Text = "金" Or Ws.Cells(4, xColumn).Text = "土" Or Ws.Cells(4, xColumn).Text = "日" Then    
  '〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓

(トラ) 2017/02/23(木) 20:28


シートモジュールのコードを消して次のコードを貼り付けてください。
excel2013でも動くよう祈っています。

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    Dim myListBox As ListBox
    Dim xRange As Range
    Dim myArray, ws As Worksheet
    Dim myListArray() As String
    Dim i As Long, j As Long, k As Long
    Dim Buf

    On Error Resume Next
    ActiveSheet.Shapes("myList").Delete
    On Error GoTo 0

    If Target.Count <> 1 Then Exit Sub
    i = Cells(Rows.Count, "B").End(xlUp).Row
    If i = 4 Then Exit Sub
    Set xRange = Cells(5, "AA").Resize(i - 4, 67)
    If Intersect(Target, xRange) Is Nothing Then Exit Sub
    If Cells(3, Target.Column).Value < Date Then Exit Sub

    Buf = "当日以降の予定入力," & _
          "入力や取消を行うとその日以降の," & _
          "黒字のスケジュールは取り消されます。," & _
          "[代休] 代休のため," & _
          "[有休] 有給休暇で休み," & _
          "[出休] 出張のため," & _
          "[公休] 公休で休み," & _
          "[当希] 当直希望," & _
          "[■休] 例外処理のために休み," & _
          "[■当] 例外処理のため当直," & _
          "[取消] セルのクリア," & _
          "[変無] 何もしない"
    myArray = Split(Buf, ",")

    j = UBound(myArray)

    Set xRange = Target.Offset(1)
    Set myListBox = ActiveSheet.ListBoxes.Add(xRange.Left, xRange.Top, 150, j * xRange.Height)
    myListBox.Name = "myList"
    myListBox.OnAction = "'SubListClick'"
    myListBox.AddItem myArray
    Set myListBox = Nothing
End Sub

標準モジュールに

'標準モジュールに書く *******シートモジュールだとエラーになる*********
'ListBoxのitemが選ばれた時の処理
Sub SubListClick()

    Dim Buf
    Dim xRange As Range

    On Error GoTo exit_sub
    Buf = ActiveSheet.ListBoxes("myList").List(ActiveSheet.ListBoxes("myList").Value)
    On Error GoTo 0

    If Buf Like "*当*" Then
        If ActiveCell.Offset(, 1).Value Like "*当*" Or ActiveCell.Offset(, -1).Value Like "*当*" Then
            MsgBox "連続当直は避けてください"
            Exit Sub
        End If
        If ActiveCell.Offset(, 1).Value Like "*休*" Then
            MsgBox "休日直前は避けてください"
            Exit Sub
        End If
    End If
    If Buf Like "*休*" Then
        If ActiveCell.Offset(, -1).Value Like "*当*" Then
            MsgBox "当直直後は避けてください"
            Exit Sub
        End If
    End If

    If Not (Buf Like "*]*") Then
        Exit Sub
    ElseIf Buf Like "*変無*" Then
        ActiveSheet.Shapes("myList").Delete
        Exit Sub
    ElseIf Mid(Buf, 2, 2) <> "取消" Then
        ActiveCell.Value = Mid(Buf, 2, 2)
        ActiveCell.Font.ColorIndex = 3  '赤
    Else
        ActiveCell.Value = ""
        ActiveCell.Font.ColorIndex = 1
    End If
    For Each xRange In ActiveCell.Offset(, 1).Resize(, 62)
        If xRange.Font.ColorIndex <> 3 Then   '赤
            xRange.ClearContents
        End If
    Next xRange

    ActiveSheet.Shapes("myList").Delete
exit_sub:
End Sub
(トラ) 2017/02/24(金) 21:40


 >トラ さん

 (トラ) 2017/02/24(金) 21:40 の修正をした結果、
 無事、Excel2013で、
 表(今日以降の日付で、5行目〜B列最終行)を左クリックすると、
 リストが表示され、リストから選択できるようになりました。

 なお、シートを全選択すると、
 Target.Count
 のところが黄色くなり、「オーバーフローしました」となってしまいます。

 調べてみたところ、
 ■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■
 ★Countプロパティ自体が、★Long型で宣言されているために起こるエラーとのこと。
 ■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■
  Excel2007以降のエクセルを使用しているなら、
 If Target.Count <> 1 Then Exit Sub
 を
 If Target.Rows.Count > 1 Or Target.Columns.Count > 1 Then Exit Sub '★
 などに変更した方が、いいと思いました。
 _
 _
     '〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓
     '詳細解説
http://excel2007.officetanaka.com/?eid=566684
    'Countプロパティ自体が、Long型で宣言されているため
    'If Target.Rows.Count <> 1 Then Exit Sub
    'だと、シート全体を選択したときに、
    'Long型の許容範囲を超えるのでエラー(オーバーフロー)となる。

                'Long型の許容範囲は、2,147,483,647個(約20億個)
    'Excel2007以降は、全セルの合計は17,179,869,184個(約170億個)
                 'Excel2007以降は、行数は1,048,576個(約100万個)
                    'Excel2007以降は、列数は16,384個(約1万個)
    '〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓
(マリオ) 2017/02/25(土) 11:37

 >トラ さん

 シートのコード記述欄に、
 「Worksheet_BeforeDoubleClick」と「Worksheet_SelectionChange」
 の2つのイベントコードを記述するのもいいかなと思いました。
 次のような感じです。

 ******* ↓ ここから (シートのコード記述内容) ****************

 Option Explicit

 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

    Dim myListBox As ListBox
    Dim xRange As Range
    Dim myArray, ws As Worksheet
    Dim myListArray() As String
    Dim i As Long, j As Long, k As Long
    Dim Buf

    On Error Resume Next
    ActiveSheet.Shapes("myList").Delete
    On Error GoTo 0

    If Target.Rows.Count > 1 Or Target.Columns.Count > 1 Then Exit Sub '★
    Cancel = True '★

    i = Cells(Rows.Count, "B").End(xlUp).Row
    If i = 4 Then Exit Sub
    Set xRange = Cells(5, "AA").Resize(i - 4, 67)
    If Intersect(Target, xRange) Is Nothing Then Exit Sub
    If Cells(3, Target.Column).Value < Date Then Exit Sub

    'Buf = "当日以降の予定入力," & _
          "入力や取消を行うとその日以降の," & _
          "黒字のスケジュールは取り消されます。," & _
          "[代休] 代休のため," & _
          "[有休] 有給休暇で休み," & _
          "[出休] 出張のため," & _
          "[公休] 公休で休み," & _
          "[当希] 当直希望," & _
          "[■休] 例外処理のために休み," & _
          "[■当] 例外処理のため当直," & _
          "[取消] セルのクリア," & _
          "[変無] 何もしない"

   '〓〓〓 simple にしてみました 〓〓〓〓 
    Buf = "[代休] ," & _
          "[有休] - 有給休暇," & _
          "[出休] - 出張で休み," & _
          "[公休] ," & _
          "[当希] - 当直希望," & _
          "[■休] - ■例外 休み," & _
          "[■当] - ■例外 当直," & _
          "[取消] - セルのクリア"
   '〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓

    myArray = Split(Buf, ",")

    j = UBound(myArray)

    Set xRange = Target.Offset(1)
    Set myListBox = ActiveSheet.ListBoxes.Add( _
                    xRange.Left, xRange.Top, 150, j * xRange.Height)

    myListBox.Name = "myList"
    myListBox.OnAction = "'SubListClick'"
    myListBox.AddItem myArray
    Set myListBox = Nothing

 End Sub

 Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    If Target.Rows.Count > 1 Or Target.Columns.Count > 1 Then Exit Sub '★

    Dim shp As Shape
    For Each shp In ActiveSheet.Shapes
        If shp.Name = "myList" Then shp.Delete
    Next shp
 End Sub

 ******* ↑ ここまで (シートのコード記述内容) ****************
(マリオ) 2017/02/25(土) 11:46

マリオさんにこの質問に加わっていただき、
色々教えてもらってありがとうございます。

If Target.Count <> 1 Then Exit Sub
この書き方は色々なところで使っていて、エラーのでる可能性がある
とは思いもしませんでした。

ActiveXコントロールを使用する方法で書いたコードは、excel2013では動作しない
というのはSinNeoさんだけの返答だったらいまだに疑心暗鬼だったと思います。

ダブルクリックとセレクトのイベントに分けるについては次のように考えます。
明確に入力の意思を持っていた場合のみ入力を認める。
入力箇所が多い場合、少しだけ手間がかかる。
なので結論は、使用者に任せる
(トラ) 2017/02/26(日) 16:56


トラ様へ
返信遅れて申し訳がありません。本当にいつもありがとうございます。

『シートモジュール』の件
投稿してくれたコードを修正し実行出来ました。Excel2013 選択するように出来ました!
素晴らしいです。分かりやすくて選択するのとてもやりやすいです。

『Sub B_Clear』は、文字が赤の件
えっと、、リフトボックス内にある「"[取消] セルのクリア," & _」を選択するとクリアなる事ですか?

質問について

■各1人 金曜日当直1回 土曜日当直1回 日曜日当直1回する事
 →コードを投稿してくれたのは、感謝してますが、相談中でしばらくお待ちください。

■中央棟当直だけの人(監視責任者の為)を設定したい
 →1〜5人くらいなので大丈夫です。数人なら問題ありません。

■資格によって、防災当直だけ除いて中央棟当直と入院当直担当する。
 →3〜5人くらいなので大丈夫です。数人なら問題ありません

■基本 専任職員の休日は、6回 委託職員の休日は、8回(理想、休日回数変更したい。)  
 →日本語不足で申し訳がありません、月に各1人専任職員の休日は6回 委託職員の休日は8回との事(理想、休日回数変更したい。)
  (出来ればランダムしてもいいが、相談中でしばらくお持ちください。申し訳がありません)

■施設「施」は何の事か説明が無い
 →専任職員だけの点検巡回・事務仕事との事なので、出来ればランダムなしで投稿してくれたコードのリフトボックス内に追加したいと思ってますが、どうでしょうか↓↓

'Buf = "当日以降の予定入力," & _

          "入力や取消を行うとその日以降の," & _
          "黒字のスケジュールは取り消されます。," & _
          "[代休] 代休のため," & _
          "[有休] 有給休暇で休み," & _
          "[出休] 出張のため," & _
          "[公休] 公休で休み," & _
          "[施休] 施設で休み," & _
          "[当希] 当直希望," & _
          "[■休] 例外処理のために休み," & _
          "[■当] 例外処理のため当直," & _
          "[取消] セルのクリア," & _
          "[変無] 何もしない"

本当は、休日じゃないけど例外として入力しました。大丈夫でしょうか

■予定「予」と表示するが、出来れば非表示したい
 →日本語不足で申し訳がありません、簡単に言いますと、予定がある時は、当直以外してほしいとの事
  出来れば、上記の通りリフトボックス内に選んで再計算してたら、文字なく非表示したい。

大丈夫でしょうか

すみませんが、相談中の所は、今週中に投稿する予定です。お手数ですが宜しくお願い致します。
また、追加する可能性がありますので宜しくお願い致します。
(SinNeo) 2017/02/27(月) 00:25


 横から失礼します。

 本件、SinNeoさんは、きわめて真面目に、かつ、しっかりと取り組んでおられると感じています。
 また、トラさん、マリオさんも 一生懸命 問題解決に尽力しておられる。 頭が下がる思いです。

 でも、それはそれとしてIP制限が解除されたようで、SInNeoさんも復帰可能になったわけですが
 SinNeoさんが行われた(と思われる)元トピに対する行為については、

[[20170223101334]] 『[談]勝手に質問を削除する人がいます』(bi)

 ここで、この『学校』の管理者である kazuさん含め、皆さんが注目されています。

 それらを無視するのではなく、それに対して SinNeoさんの言葉でコメントをしていただきたいと思っています。
 
( β) 2017/02/27(月) 00:36

SinNeoさんへ

■資格によって、防災当直だけ除いて中央棟当直と入院当直担当する。

 →3〜5人くらいなので大丈夫です。数人なら問題ありません 
 同一日に入院当直担当が二人選ばれた時に、片方は、中央棟か防災に回る事になる
 これを避けるためには、元々の当直選抜に遡りコードの変更が必要になり大変だという事です。

 ここで(休)で表示されているのは当直が出来ないという意味で、
 その日に他で仕事をしようが休んでいようが出張だろうが関係ないです。
 基本 専任職員の休日は、6回 委託職員の休日は、8回(理想、休日回数変更したい・・・等は
 処理に関係ないと思います。

 施設「施」は休日じゃないけど例外として入力しました。・・・大丈夫です。

■予定「予」と表示するが、出来れば非表示したい

 貴方の記憶力が非常に優れていて、予定をクリアされても復元でき、
 その手間を惜しまないのであれば可能ですが、非表示にしないことをお勧めします。
 "[施休] 施設で休み," & _ の下にでも
 "[予休] 予定で休み," & _ 
 とコードを加えてください。

今日、シュミレーションして見ました。

 例えば、山田さんが交通事故で2/27から休職、新人が3/5から当直可能

 その時、Sub B_Clearを使ってセルのクリアをする。
 その時、赤字の物・・・貴方が個別に入力した代休有給出休・・・等の
 予定は消えないようになっています。

★その時みつけた、修正箇所です。

 Sub Sh1_6当直を中央棟担当_入院棟担当_防災担当に振り分ける()
    '〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓
    '修正前
     'If Ws.Cells(xRow, "D").Value Like "*責任*" And myDic("当中") > 0 Then
    '〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓
    '修正後
     If Buf Like "当中" Then
         myDic("当中") = myDic("当中") - 1
     ElseIf Ws.Cells(xRow, "D").Value Like "*責任*" And myDic("当中") > 0 Then
    '〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓
(トラ) 2017/02/27(月) 19:12

トラ様へ
返信遅れて申し訳がありません。本当にいつもありがとうございます。

■資格によって、防災当直だけ除いて中央棟当直と入院当直担当する。
 →えっと、すみません
  入院棟当直二人選ばれるのはありませんが、1人決まりです。
  中央棟と入院棟当直するのは、コード変更必要で大変ですか、、

■施設「施」
 →ありがとうございます。問題なく実行出来ました。
 →すみませんが、出来れば当直のようなみたく1日に1人だけ、ランダム(専任職員だけ)したいですが、どうしたらいいでしょうか

■(休)で表示されているのは当直が出来ないという意味の件
 →なるほど。大丈夫です!追加しても問題ないですね。

■予定「予」
 →わかりました。コード追加し問題なく実行出来ました。

■シュミレーションの件
 →なるほどです。やりやすいです。

■修正箇所の件
 →ありがとうございます。修正しました。

■各1人 金曜日当直1回 土曜日当直1回 日曜日当直1回する事
 →お待たせしました。決まりました。
  コード投稿してくれたのは、心から感謝しております。

  下記のとおりです。
  専任職員
    その通りで各1人 金曜日当直1回 土曜日当直1回 日曜日当直1回する事
  委託職員
    土・日曜日当直が、3回まで 金曜日は何回でも大丈夫です。

■追加の件
 誠意がまったく感じられませんのは、承知しております。
 
 当直の追加
 ・・入院棟当直担当除いて、中央棟当直担当と防災センター当直担当する
 ・中央棟当直(監視責任者だけ)が、金曜日当直しても大丈夫ですが、金曜日当直明けだけは控えてほしいです。
 ・上から7人目までの中(専任職員)に3人以上に選ぶのは、やめて欲しいです。
 ・上から7人目までの中(専任職員)に1人に選ばれた時は、8人目から下までの中(専任職員)に、2〜3名選ぶ、委託職員は、1人以上
 ・上から7人目までの中(専任職員)に2人に選ばれた時は、8人目から下までの中(専任職員)に、2〜3名選ぶ、委託職員は、1人以上

 例外として
 ・専任職員忘年会等の時は、専任職員2人、委託職員3人以上とする
 ・専任職員忘年会等の時は、委託職員5人とする
 ・委託職員忘年会等の時は、専任職員5人とする

 自分もやったんですが、どうしたらいいのか分からなくなりました、、どうしたらいいでしょうか

 お手数ですが、宜しくお願い致します。

 勿論、これで全部当直条件(今まで投稿した)です。

■『指定日以降のスケジュールをクリアする』に伴い、日の変更について
 ・Set xRange = Application.InputBox(Prompt:=Date + ● & "以降の日付けのあるセルを選択してください。", Type:=8)
 ・If xDate < Date + ● Then

        MsgBox "今日から●日後までのスケジュールはクリアできません"

  ●の所に数字変更しても大丈夫してもいいでしょうか
  試しに実行しましたが、問題なく出来ました。

日勤と休日と色のついては、当直出来ましたら投稿予定です。

日本語不足で話を通じない事をあると思いますが、宜しくお願いします。

迷惑をかけて申し訳がありません。お手数ですが、宜しくお願い致します。
(SinNeo) 2017/03/06(月) 14:53


■資格によって、防災当直だけ除いて中央棟当直と入院当直担当する。
   入院棟当直二人選ばれるのはありませんが、1人決まりです。 
   中央棟と入院棟当直するのは、コード変更必要で大変ですか、、
    大変ですが、乗りかかった船で、修正しましょう。

■施設「施」

  →すみませんが、出来れば当直のようなみたく1日に1人だけ、ランダム(専任職員だけ)したいですが、どうしたらいいでしょうか 
 当直に関係ないので、出来ません。貴方が一人一人入力するほかありません。

■各1人 金曜日当直1回 土曜日当直1回 日曜日当直1回する事

   専任職員 
     その通りで各1人 金曜日当直1回 土曜日当直1回 日曜日当直1回する事 
     なるべく一回にするが忘年会等が有るので確実ではない。
   委託職員 
     金・土・日曜日当直は回数制限無にします。・・・変更不可

  ・・入院棟当直担当除いて、中央棟当直担当と防災センター当直担当する・・・そのように成っている

**************** 対応不可

 ・中央棟当直(監視責任者だけ)が、金曜日当直しても大丈夫ですが、金曜日当直明けだけは控えてほしいです。 
 ・上から7人目までの中(専任職員)に3人以上に選ぶのは、やめて欲しいです。 
 ・上から7人目までの中(専任職員)に1人に選ばれた時は、8人目から下までの中(専任職員)に、2〜3名選ぶ、委託職員は、1人以上 
 ・上から7人目までの中(専任職員)に2人に選ばれた時は、8人目から下までの中(専任職員)に、2〜3名選ぶ、委託職員は、1人以上 

前提がまったく違うので、対応不可
上級専任職員、一般専任職員、委託職員と三種類の職員がいて。それぞれから、1〜2人を選び
合計五人で当直を行う様な処理を最初から作らないと無理です。

 ・専任職員忘年会等の時は、専任職員2人、委託職員3人以上とする 
 ・専任職員忘年会等の時は、委託職員5人とする 
 上の行と下の行では、矛盾している

■の二箇所だけの変更になりますが、続行しますか ??????????????????????????????
(トラ) 2017/03/06(月) 21:10


トラ様へ
返信遅れて申し訳がありません。本当にいつもありがとうございます。

・■の件について
 問題はありません、ありがとうございます。
 すみませんが宜しくお願い致します。

・『対応不可』について
 すみません、中途半端で言って申し訳がありません。前に持って言わなかったの事を反省してます。
 誠意がまったく感じられませんのは承知しており、無理なのは分かってますが、もし出来るんなら別として教えてください。勉強になりますしVBA色々なこと知りたいなと思ってます。無理なら大丈夫です。

迷惑をかけて申し訳がありません。お手数ですが、宜しくお願い致します。
(SinNeo) 2017/03/07(火) 13:42


 余計なお世話だと思いますが
 人に死ぬな、怪我をするな、年をとるな、仕事変えるな
 なんてことは無理ですよね。

 ・上から7人目までの中(専任職員)に3人以上に選ぶのは、やめて欲しいです。 
 ・上から7人目までの中(専任職員)に1人に選ばれた時は、8人目から下までの中(専任職員)に、2〜3名選ぶ、委託職員は、1人以上 
 ・上から7人目までの中(専任職員)に2人に選ばれた時は、8人目から下までの中(専任職員)に、2〜3名選ぶ、委託職員は、1人以上 

 上のような処理を組み込んだとして、次のようなケースに対応できますか。

 上から二行目の人が何らかの理由で、4/1までで当直から離脱、
 上から十一行目の人を、3/25で上から7人目までのグループに編成替え
 新人を4/1から8人目以降のグループに加える

 このような事を最初から考慮に入れて、次のようなフォーマットになりました。
 新しいブックに貼り付けて、
 Sub Sh1_1最初に見出しと罫線のセット()
 Sub C_Hidden()
 を実行してください。

 Sub A_Main()
    Application.EnableEvents = False
    Randomize
    Sheets("Sheet1").Select

    Call Sh1_2前月末5日_当月_来月表を当月末5日_来月_来来月にする

    Call Sh1_02初日終了日で当直日数補正

    Call Sh1_4三ヶ月のスケジュール表に当直を記入の予備動作

    Call Sh1_6スケジュール表に当直を計算

    Call Sh1_6当直を中央棟担当_入院棟担当_防災担当に振り分ける
    Application.EnableEvents = True
End Sub

'人員の増減が有った時に実行、当直数のばらつきが大きい時があるのでその時実行
Sub B_Clear()

    Application.EnableEvents = False
    Call sh1_40指定日以降のスケジュールをクリアする
    Application.EnableEvents = True
End Sub

Sub C_Hidden()

    Sheets("Sheet1").Select
    If Columns("E").Hidden = True Then
        Columns("E").Resize(, 23).Hidden = False
    Else
        Columns("E").Resize(, 23).Hidden = True
    End If
End Sub

'まっさらのSheets("Sheet1")に最初に実行
'AA列5行目以降のスケジュール表内の文字色は変えてはいけない
'罫線で囲まれた項目の配置変更はできない。彩色は自由

Sub Sh1_1最初に見出しと罫線のセット()

    Dim sss, i, j, k
    Dim Ws As Worksheet, regAA2 As Range
    Dim xDate As Date

    Sheets("Sheet1").Select
    Rows(2).Resize(3).HorizontalAlignment = xlCenter

    Cells(3, "H").Resize(, 6).Merge
    Cells(3, "N").Resize(, 6).Merge
    Cells(3, "T").Resize(, 6).Merge
    Cells(3, "H").Value = "過去一月の"
    Cells(3, "N").Value = Month(Date) & "月の"
    Cells(3, "T").Value = "来月の"
    sss = "名前,所属,専門,初日,終了日,,当直数,日数補正,金土日,中央棟,入院棟,防災,当直数," & _
          "日数補正,金土日,中央棟,入院棟,防災,当直数,日数補正,金土日,中央棟,入院棟,防災"
    sss = Split(sss, ",")
    Cells(4, "B").Resize(, UBound(sss) + 1).Value = sss
    Cells(5, "B").Resize(32).Formula = "=""名前""&Row()"
    Cells(5, "B").Resize(32).Value = Cells(5, "B").Resize(32).Value
    Cells(5, "C").Resize(26).Value = "専任"
    Cells(31, "C").Resize(6).Value = "委託"
    Cells(5, "H").Resize(32).Value = 7
    'Cells(5, "G").Resize(32).Formula = "=SUM(H5,N5,T5)"

    Cells(3, "N").Resize(3, 6).Interior.ColorIndex = 40
    Rows(5).Resize(11).Interior.ColorIndex = 34
    Rows(16).Resize(15).Interior.ColorIndex = 36
    Rows(31).Resize(9).Interior.ColorIndex = 35
    Rows(12).Resize(4).ClearContents
    Rows(26).Resize(5).ClearContents

    Set regAA2 = Cells(2, "AA").Resize(38, 67)
    regAA2.Resize(1).NumberFormatLocal = "M"
    regAA2.Resize(1).Offset(1).NumberFormatLocal = "D"
    regAA2.Resize(1).Offset(2).NumberFormatLocal = "aaa"

    Cells(3, "H").Resize(37, 18).Borders.LineStyle = True
    Cells(4, "B").Resize(36, 5).Borders.LineStyle = True
    regAA2.Borders.LineStyle = True

    regAA2.ColumnWidth = 3.5
    regAA2.Resize(3, 67).Interior.ColorIndex = 35
    j = Day(DateSerial(Year(Date), Month(Date) + 1, 0))
    regAA2.Offset(, 5).Resize(3, j).Interior.ColorIndex = 40

    Set regAA2 = regAA2.Resize(1, 1)
    xDate = DateSerial(Year(Date), Month(Date), 0) - 4
    For i = 0 To 66
        If xDate + i > DateSerial(Year(xDate), Month(xDate) + 3, 0) Then Exit For
        regAA2.Offset(, i).Value = xDate + i
        regAA2.Offset(1, i).Value = xDate + i
        regAA2.Offset(2, i).Value = xDate + i
        If Format(xDate + i, "aaa") = "土" Then regAA2.Offset(2, i).Interior.ColorIndex = 6
        If Format(xDate + i, "aaa") = "日" Then regAA2.Offset(2, i).Interior.ColorIndex = 3
    Next i

    Range("B:Y").ColumnWidth = 6.5
    Range("A:A,G:G,Z:Z").ColumnWidth = 3.5
 End Sub

(トラ) 2017/03/08(水) 16:24


トラ様へ
ありがとうございます。
本当に中途半端で迷惑を掛けて申し訳がありません。

 Sub Sh1_1最初に見出しと罫線のセット()
 Sub C_Hidden()
実行し確認しました。とても見やすくて素晴らしいです。セル非表示(隠す)は凄くいいです。

・『AA列5行目以降のスケジュール表内の文字色は変えてはいけない』→分かりました

・『罫線で囲まれた項目の配置変更はできない。彩色は自由』
 →行挿入(追加)出来ないってことですか?
 →『彩色は自由』は塗りつぶしですか?

あと、すみませんが
コード表投稿してくれた事を心から感謝しております。
日付自動更新なってますが、出来れば、下のタブに4月〜翌年3月(1年度分12個)シートを追加したいんですが
大丈夫でしょうか、、
無理ならそのままでも大丈夫です。

お手数をおかけしますが、宜しくお願い致します。
(SinNeo) 2017/03/09(木) 00:27


→行挿入(追加)出来ないってことですか?・・・そうです。
最終行は増やせます。
→『彩色は自由』は塗りつぶしですか・・・そうです。
日付自動更新なってますが、追加しても大丈夫・・・自分でやって

追加の要望も全て盛り込んでいます。

新しい標準モジュールに貼り付けてください。

 Option Explicit
 Option Private Module

 Sub Sh1_6スケジュール表に当直を計算()
    Dim i As Long, j As Long, k As Long, n As Long
    Dim xRow As Long, MaxRow As Long, iMember As Long
    Dim Ws As Worksheet
    Dim myRange As Range, xRange As Range, regAA2 As Range
    Dim xDate As Date, myDate As Date, yDate As Date, AFDate As Date
    Dim AFColumn As Long, CLColumn As Long, xColumn As Long

    Call SetDimName_(Ws, MaxRow, iMember, AFColumn, CLColumn, regAA2, AFDate)

    Dim i当 As Long, i当専任 As Long, i当委託 As Long, i入院棟 As Long
    Dim Buf As Variant, kkk As Long, iii As Long
    Dim ttt4 As Long, ttt5 As Long, ttt8 As Long, ttt9 As Long
    Dim tukiColumn As Long, s専任委託 As String
    Dim i上下 As Long, c上下 As Long

    c上下 = 15   '専任職員の上位グループ 11人 + 4行値・・・責任者グループ
    Ws.Cells(5, "N").Resize(iMember, 1).ClearContents
    Ws.Cells(5, "P").Resize(iMember, 5).ClearContents
    Ws.Cells(5, "V").Resize(iMember, 4).ClearContents

    For xColumn = AFColumn To CLColumn
        yDate = Ws.Cells(3, xColumn).Value

        i当 = WorksheetFunction.CountIf(Ws.Cells(5, xColumn).Resize(iMember), "*当*")
        If i当 > 5 Then
            MsgBox "当直 > 5 Error"
            MsgBox Ws.Cells(5, xColumn).Resize(iMember).Address
            End
        End If

        i当専任 = 0
        i当委託 = 0
        i入院棟 = 0
        For j = 5 To MaxRow
            Buf = Ws.Cells(j, xColumn).Value
            If Buf Like "*当*" Then
                If Ws.Cells(j, "C").Value Like "*専任*" Then
                    i当専任 = i当専任 + 1
                ElseIf Ws.Cells(j, "C").Value Like "*委託*" Then
                    i当委託 = i当委託 + 1
                End If
                If Ws.Cells(j, "D").Value Like "*入院*" Then
                    i入院棟 = i入院棟 + 1
                End If
            End If
        Next j

        '1専任職員
        i上下 = c上下  '>>>>Row
        s専任委託 = "*専任*"
        n = 4
        For k = 1 To 1 - i当専任
            Call Sh1_6088スケジュール表に当直を計算(Ws, n, s専任委託, MaxRow, xColumn, AFDate, yDate, _
                                       xRow, i当専任, i当委託, j, Buf, kkk, ttt4, ttt5, ttt8, ttt9, i入院棟, i上下, c上下)
        Next k
        n = 3
        For k = 1 To 1 - i当専任
            Call Sh1_6088スケジュール表に当直を計算(Ws, n, s専任委託, MaxRow, xColumn, AFDate, yDate, _
                                       xRow, i当専任, i当委託, j, Buf, kkk, ttt4, ttt5, ttt8, ttt9, i入院棟, i上下, c上下)
        Next k
        n = 2
        For k = 1 To 1 - i当専任
            Call Sh1_6088スケジュール表に当直を計算(Ws, n, s専任委託, MaxRow, xColumn, AFDate, yDate, _
                                       xRow, i当専任, i当委託, j, Buf, kkk, ttt4, ttt5, ttt8, ttt9, i入院棟, i上下, c上下)
        Next k

        '3専任職員
        i上下 = 999
        s専任委託 = "*専任*"
        n = 4
        For k = 1 To 3 - i当専任
            Call Sh1_6088スケジュール表に当直を計算(Ws, n, s専任委託, MaxRow, xColumn, AFDate, yDate, _
                                       xRow, i当専任, i当委託, j, Buf, kkk, ttt4, ttt5, ttt8, ttt9, i入院棟, i上下, c上下)
        Next k
        n = 3
        For k = 1 To 3 - i当専任
            Call Sh1_6088スケジュール表に当直を計算(Ws, n, s専任委託, MaxRow, xColumn, AFDate, yDate, _
                                       xRow, i当専任, i当委託, j, Buf, kkk, ttt4, ttt5, ttt8, ttt9, i入院棟, i上下, c上下)
        Next k
        n = 2
        For k = 1 To 3 - i当専任
            Call Sh1_6088スケジュール表に当直を計算(Ws, n, s専任委託, MaxRow, xColumn, AFDate, yDate, _
                                       xRow, i当専任, i当委託, j, Buf, kkk, ttt4, ttt5, ttt8, ttt9, i入院棟, i上下, c上下)
        Next k

        i上下 = 555  '>>>>Row
        '1委託職員
        s専任委託 = "*委託*"
        n = 4
        For k = 1 To 1 - i当委託
            Call Sh1_6088スケジュール表に当直を計算(Ws, n, s専任委託, MaxRow, xColumn, AFDate, yDate, _
                                       xRow, i当専任, i当委託, j, Buf, kkk, ttt4, ttt5, ttt8, ttt9, i入院棟, i上下, c上下)
        Next k
        n = 3
        For k = 1 To 1 - i当委託
            Call Sh1_6088スケジュール表に当直を計算(Ws, n, s専任委託, MaxRow, xColumn, AFDate, yDate, _
                                       xRow, i当専任, i当委託, j, Buf, kkk, ttt4, ttt5, ttt8, ttt9, i入院棟, i上下, c上下)
        Next k
        n = 2
        For k = 1 To 1 - i当委託
            Call Sh1_6088スケジュール表に当直を計算(Ws, n, s専任委託, MaxRow, xColumn, AFDate, yDate, _
                                       xRow, i当専任, i当委託, j, Buf, kkk, ttt4, ttt5, ttt8, ttt9, i入院棟, i上下, c上下)
        Next k

        '1全職員
        i当 = WorksheetFunction.CountIf(Ws.Cells(5, xColumn).Resize(iMember), "*当*")
        s専任委託 = "*"
        n = 4
        For k = i当 + 1 To 5
            Call Sh1_6088スケジュール表に当直を計算(Ws, n, s専任委託, MaxRow, xColumn, AFDate, yDate, _
                                       xRow, i当専任, i当委託, j, Buf, kkk, ttt4, ttt5, ttt8, ttt9, i入院棟, i上下, c上下)
        Next k

        '1全職員
        i当 = WorksheetFunction.CountIf(Ws.Cells(5, xColumn).Resize(iMember), "*当*")
        s専任委託 = "*"
        n = 3
        For k = i当 + 1 To 5
            Call Sh1_6088スケジュール表に当直を計算(Ws, n, s専任委託, MaxRow, xColumn, AFDate, yDate, _
                                       xRow, i当専任, i当委託, j, Buf, kkk, ttt4, ttt5, ttt8, ttt9, i入院棟, i上下, c上下)
        Next k

        '専任職員
        s専任委託 = "*専任*"
        i当 = WorksheetFunction.CountIf(Ws.Cells(5, xColumn).Resize(iMember), "*当*")
        n = 2
        For k = i当 + 1 To 5
            Call Sh1_6088スケジュール表に当直を計算(Ws, n, s専任委託, MaxRow, xColumn, AFDate, yDate, _
                                       xRow, i当専任, i当委託, j, Buf, kkk, ttt4, ttt5, ttt8, ttt9, i入院棟, i上下, c上下)
        Next k

        '委託職員
        s専任委託 = "*委託*"
        i当 = WorksheetFunction.CountIf(Ws.Cells(5, xColumn).Resize(iMember), "*当*")
        n = 2
        For k = i当 + 1 To 5
            Call Sh1_6088スケジュール表に当直を計算(Ws, n, s専任委託, MaxRow, xColumn, AFDate, yDate, _
                                       xRow, i当専任, i当委託, j, Buf, kkk, ttt4, ttt5, ttt8, ttt9, i入院棟, i上下, c上下)
        Next k

        Call Sh1_44スケジュール表に当直を記入当日の予備動作(xColumn)
    Next xColumn

    '   セルに書き込んだ数字をクリアする
    Ws.Cells(5, "AA").Resize(iMember, 72).SpecialCells(xlCellTypeConstants, 1).ClearContents
 End Sub

 'call>>(Ws, n, s専任委託, MaxRow, xColumn, AFDate, yDate, xRow, i当専任, i当委託, j, Buf, kkk, ttt4, ttt5, ttt8, ttt9, i入院棟, i上下, c上下)
 Private Sub Sh1_6088スケジュール表に当直を計算(ByRef Ws As Worksheet, ByRef n As Long, ByRef s専任委託 As  String, ByRef MaxRow As Long, _
                                  ByRef xColumn As Long, ByRef AFDate As Date, ByRef yDate As Date, ByRef xRow As Long, _
                                  ByRef i当専任 As Long, ByRef i当委託 As Long, ByRef j As Long, ByRef Buf As Variant, ByRef kkk As Long, _
                                  ByRef ttt4 As Long, ByRef ttt5 As Long, ByRef ttt8 As Long, ByRef ttt9 As Long, _
                                  ByRef i入院棟 As Long, ByRef i上下 As Long, ByRef c上下 As Long)

    kkk = 0  '当直間隔  = Buf
    ttt4 = 999    'スケジュールしている月の当直数
    ttt8 = 999    '前月の当直数 +(有れば)前前月の当直数

    For j = MaxRow To 5 Step -1
        ttt9 = Ws.Cells(j, "H").Value + Ws.Cells(j, "N").Value + Ws.Cells(j, "T").Value + _
               Ws.Cells(j, "I").Value + Ws.Cells(j, "O").Value + Ws.Cells(j, "U").Value

        If Month(AFDate) = Month(yDate) Then
            ttt5 = Ws.Cells(j, "N").Value + Ws.Cells(j, "O").Value
        Else
            ttt5 = Ws.Cells(j, "T").Value + Ws.Cells(j, "U").Value
        End If

        Buf = Ws.Cells(j, xColumn).Value
        If Ws.Cells(4, xColumn).Text = "金" Or Ws.Cells(4, xColumn).Text = "土" Or Ws.Cells(4, xColumn).Text = "日" Then
            If Ws.Cells(j, "C").Value Like "*専任*" Then
                If Buf = "" Then
                    Buf = 6
                End If
            Else
                If Buf <> "" Then
                    If IsNumeric(Buf) Then
                        If Buf <> 1 Then Buf = Buf + 1
                    End If
                End If
            End If
        Else
            If Ws.Cells(j, "C").Value Like "*専任*" Then
                If Buf <> "" Then
                    If IsNumeric(Buf) Then
                        If Buf <> 1 Then Buf = Buf + 1
                    End If
                End If
            Else
                If Buf = "" Then
                    Buf = 6
                End If
            End If
        End If

        If Buf Like "*当*" Then
            Ws.Cells(j, xColumn).Value = "当直"
        ElseIf Ws.Cells(j, "B").Value = "" Then
        ElseIf Ws.Cells(j, "D").Value Like "*責任*" And Ws.Cells(4, xColumn).Text = "木" Then
        ElseIf Buf Like "*休*" Then
        ElseIf Buf = 1 Then
        ElseIf i当専任 + i当委託 >= 5 Then
        ElseIf i上下 = c上下 And j > c上下 Then
        ElseIf i上下 = 999 And j <= c上下 Then
        ElseIf i入院棟 > 0 And Ws.Cells(j, "D").Value Like "*入院*" Then
        ElseIf Not (Ws.Cells(j, "C").Value Like s専任委託) Then
        ElseIf Ws.Cells(j, "E").Value > Ws.Cells(3, xColumn).Value Then
        ElseIf Ws.Cells(j, "F").Value < Ws.Cells(3, xColumn).Value And Ws.Cells(j, "F").Value <> "" Then
        ElseIf Buf = "" Then
            If kkk <> 999 Then
                xRow = j
                kkk = 999
            Else
                If Rnd > 0.67 Then
                    xRow = j
                End If
            End If
        ElseIf Buf >= n And kkk <> 999 Then
            If ttt4 > ttt5 Then
                xRow = j
                kkk = Buf
                ttt4 = ttt5
                ttt8 = ttt9
            ElseIf ttt4 = ttt5 Then
                If ttt8 > ttt9 Then
                    xRow = j
                    kkk = Buf
                    ttt4 = ttt5
                    ttt8 = ttt9
                ElseIf ttt8 = ttt9 Then
                    If kkk < Buf Then
                        xRow = j
                        kkk = Buf
                        ttt4 = ttt5
                        ttt8 = ttt9
                    ElseIf kkk = Buf Then
                        If Rnd > 0.67 Then
                            xRow = j
                        End If
                    End If
                End If
            End If
        End If
    Next j

    If kkk >= 2 Then
        If Ws.Cells(xRow, "C").Value Like "*委*" Then
            Ws.Cells(xRow, xColumn).Value = "当直"
            i当委託 = i当委託 + 1
        Else
            Ws.Cells(xRow, xColumn).Value = "当直"
            i当専任 = i当専任 + 1
        End If

        If Ws.Cells(xRow, "D").Value Like "*入院*" Then
            i入院棟 = i入院棟 + 1
        End If
    End If
 End Sub

 '   "当直"を中央棟担当、入院棟担当、防災担当に振り分ける
 Sub Sh1_6当直を中央棟担当_入院棟担当_防災担当に振り分ける()
    Dim i As Long, j As Long, k As Long, n As Long
    Dim xRow As Long, MaxRow As Long
    Dim Ws As Worksheet, xRange As Range
    Dim sColumn As Long, eColumn As Long, xColumn As Long
    Dim iMember As Long, Buf As String
    Dim i中央棟 As Long, i入院棟 As Long, i防災 As Long
    Dim Buf1, Buf2
    Dim myDic As Object, myDicItems As Variant

    Set myDic = CreateObject("Scripting.Dictionary")
    Set Ws = Sheets("Sheet1")
    MaxRow = Ws.Range("B" & Rows.Count).End(xlUp).Row
    iMember = MaxRow - 4

    '当月、来月の中央棟担当、入院棟担当、防災担当をクリアする
    Ws.Cells(5, "Q").Resize(iMember, 3).Value = 0
    Ws.Cells(5, "W").Resize(iMember, 3).Value = 0

    Application.ScreenUpdating = False
    For xColumn = Ws.Cells(3, "AF").Column To Ws.Cells(3, "CO").Column
        If Month(Ws.Cells(3, xColumn).Value) = Month(Ws.Cells(3, "AF").Value) Then
            sColumn = 14
        Else
            sColumn = 20
        End If
        myDic.removeall
        myDic("当中") = 3
        myDic("当入") = 1
        myDic("当防") = 1

        For xRow = 5 To MaxRow
            Buf = Ws.Cells(xRow, xColumn).Value
            If Buf Like "*当*" Then
                If Buf Like "当中" Then
                    myDic("当中") = myDic("当中") - 1
                ElseIf Ws.Cells(xRow, "D").Value Like "*責任*" And myDic("当中") > 0 Then
                    If myDic("当中") > 0 Then
                        Ws.Cells(xRow, xColumn).Value = "当中"
                        Ws.Cells(xRow, sColumn + 3).Value = Ws.Cells(xRow, sColumn + 3).Value + 1
                        myDic("当中") = myDic("当中") - 1
                    End If
                End If
            End If
        Next xRow

        For xRow = 5 To MaxRow
            Buf = Ws.Cells(xRow, xColumn).Value
            If Buf Like "*当*" And Buf <> "当中" Then
                If (Ws.Cells(xRow, "D").Value Like "*中央*" Or Ws.Cells(xRow, "D").Value Like "*責任*") And myDic("当中") > 0 Then
                    Ws.Cells(xRow, xColumn).Value = "当中"
                    Ws.Cells(xRow, sColumn + 3).Value = Ws.Cells(xRow, sColumn + 3).Value + 1
                    myDic("当中") = myDic("当中") - 1
                ElseIf Ws.Cells(xRow, "D").Value Like "*入院*" And myDic("当入") > 0 Then
                    Ws.Cells(xRow, xColumn).Value = "当入"
                    Ws.Cells(xRow, sColumn + 4).Value = Ws.Cells(xRow, sColumn + 4).Value + 1
                    myDic("当入") = myDic("当入") - 1
                Else
                    myDic(xRow) = xRow _
                                & "|" & Ws.Cells(xRow, "K").Value + Ws.Cells(xRow, "Q").Value + Ws.Cells(xRow, "W").Value _
                                & "|" & Ws.Cells(xRow, "L").Value + Ws.Cells(xRow, "R").Value + Ws.Cells(xRow, "X").Value _
                                & "|" & Ws.Cells(xRow, "M").Value + Ws.Cells(xRow, "S").Value + Ws.Cells(xRow, "Y").Value
                End If
            End If
        Next xRow

        myDicItems = myDic.items
        For j = 0 To 30
            For i = 3 To UBound(myDicItems)
                Buf1 = myDicItems(i)
                Buf2 = Split(Buf1, "|")
                If Buf2(1) = j And myDic("当中") > 0 Then
                    Ws.Cells(Buf2(0), xColumn).Value = "当中"
                    Ws.Cells(Buf2(0), sColumn + 3).Value = Ws.Cells(Buf2(0), sColumn + 3).Value + 1
                    myDic("当中") = myDic("当中") - 1
                    myDicItems(i) = "99|99|99|99"
                End If
            Next i
            For i = 3 To UBound(myDicItems)
                Buf1 = myDicItems(i)
                Buf2 = Split(Buf1, "|")
                If Buf2(2) = j And myDic("当入") > 0 Then
                    Ws.Cells(Buf2(0), xColumn).Value = "当入"
                    Ws.Cells(Buf2(0), sColumn + 4).Value = Ws.Cells(Buf2(0), sColumn + 4).Value + 1
                    myDic("当入") = myDic("当入") - 1
                    myDicItems(i) = "99|99|99|99"
                End If
            Next i
            For i = UBound(myDicItems) To 3 Step -1
                Buf1 = myDicItems(i)
                Buf2 = Split(Buf1, "|")
                If Buf2(3) = j And myDic("当防") > 0 Then
                    Ws.Cells(Buf2(0), xColumn).Value = "当防"
                    Ws.Cells(Buf2(0), sColumn + 5).Value = Ws.Cells(Buf2(0), sColumn + 5).Value + 1
                    myDic("当防") = myDic("当防") - 1
                    myDicItems(i) = "99|99|99|99"
                End If
            Next i
        Next j
    Next xColumn
 End Sub

 '''スケジュール表には、前月末5日、当月、来月の日付けがある
 Private Sub Sh1_44スケジュール表に当直を記入当日の予備動作(ByVal ssColumn As Long)
    Dim i As Long, j As Long, k As Long, n As Long
    Dim xRow As Long, MaxRow As Long, iMember As Long
    Dim Ws As Worksheet
    Dim myRange As Range, xRange As Range, regAA2 As Range
    Dim xDate As Date, myDate As Date, yDate As Date, AFDate As Date
    Dim AFColumn As Long, CLColumn As Long, xColumn As Long

    Call SetDimName_(Ws, MaxRow, iMember, AFColumn, CLColumn, regAA2, AFDate)

    Dim xAverage As Single
    Dim xSingle As Single, ySingle As Single
    Dim SumDate As Date

    AFDate = Ws.Cells(3, "AF").Value
    yDate = Ws.Cells(3, ssColumn).Value

    Application.ScreenUpdating = False

    For xRow = 5 To MaxRow
        '"1"の所は当直不可、"2"のところは他に当直可能者がいれば当直しない。
        If InStr(Ws.Cells(xRow, ssColumn), "当") Then
            If Month(AFDate) = Month(yDate) Then
                Ws.Cells(xRow, "N") = Ws.Cells(xRow, "N") + 1
            Else
                Ws.Cells(xRow, "T") = Ws.Cells(xRow, "T") + 1
            End If

            If Ws.Cells(xRow, ssColumn + 1).Value = "" Then Ws.Cells(xRow, ssColumn + 1).Value = 1
            If Ws.Cells(xRow, ssColumn + 2).Value = "" Then Ws.Cells(xRow, ssColumn + 2).Value = 3
            If Ws.Cells(xRow, ssColumn + 3).Value = "" Then Ws.Cells(xRow, ssColumn + 3).Value = 4
            If Ws.Cells(xRow, ssColumn + 4).Value = "" Then Ws.Cells(xRow, ssColumn + 4).Value = 5
            If Ws.Cells(xRow, ssColumn + 5).Value = "" Then Ws.Cells(xRow, ssColumn + 5).Value = 6

            If IsNumeric(Ws.Cells(xRow, ssColumn + 1).Value) Then
                If Ws.Cells(xRow, ssColumn + 1).Value > 1 Then Ws.Cells(xRow, ssColumn + 1).Value = 1
            End If
            If IsNumeric(Ws.Cells(xRow, ssColumn + 2).Value) Then
                If Ws.Cells(xRow, ssColumn + 2).Value > 3 Then Ws.Cells(xRow, ssColumn + 2).Value = 3
            End If
            If IsNumeric(Ws.Cells(xRow, ssColumn + 3).Value) Then
                If Ws.Cells(xRow, ssColumn + 3).Value > 4 Then Ws.Cells(xRow, ssColumn + 3).Value = 4
            End If
            If IsNumeric(Ws.Cells(xRow, ssColumn + 4).Value) Then
                If Ws.Cells(xRow, ssColumn + 4).Value > 5 Then Ws.Cells(xRow, ssColumn + 4).Value = 5
            End If
            If IsNumeric(Ws.Cells(xRow, ssColumn + 5).Value) Then
                If Ws.Cells(xRow, ssColumn + 5).Value > 6 Then Ws.Cells(xRow, ssColumn + 5).Value = 6
            End If

            '金土日の当直を月一回に限定したい・・・
            If Ws.Cells(4, ssColumn).Text = "金" Or Ws.Cells(4, ssColumn).Text = "土" Or Ws.Cells(4, ssColumn).Text = "日" Then
                If Month(AFDate) = Month(yDate) Then
                    xColumn = AFColumn + Day(DateSerial(Year(AFDate), Month(AFDate) + 1, 0))
                    Ws.Cells(xRow, "P").Value = Ws.Cells(xRow, "P").Value & Ws.Cells(4, ssColumn).Text
                Else
                    xColumn = CLColumn
                    Ws.Cells(xRow, "V").Value = Ws.Cells(xRow, "V").Value & Ws.Cells(4, ssColumn).Text
                End If
                If Ws.Cells(xRow, "C").Value Like "*専任*" Then
                    For i = ssColumn + 7 To xColumn Step 7
                        If Ws.Cells(xRow, i).Value = "" Then Ws.Cells(xRow, i).Value = 2
                        If IsNumeric(Ws.Cells(xRow, i).Value) Then
                            If Ws.Cells(xRow, i).Value > 2 Then Ws.Cells(xRow, i).Value = 2
                        End If
                    Next i
                End If
            End If
        End If
    Next xRow
 End Sub

 '    指定日以降のスケジュールをクリアする
 Sub sh1_40指定日以降のスケジュールをクリアする()
    Dim Ws As Worksheet, myRange As Range, xRange As Range
    Dim regAA2 As Range
    Dim MaxRow As Long
    Dim xDate As Date

    Sheets("Sheet1").Select
    On Error Resume Next
    Set xRange = Application.InputBox(Prompt:=Date + 7 & "以降の日付けのあるセルを選択してください。", Type:=8)
    If Err.Number <> 0 Then Exit Sub
    On Error GoTo 0
    If xRange.Column < Cells(1, "AF").Column Then Exit Sub
    If xRange.Column > Cells(1, "CO").Column Then Exit Sub
    Columns(xRange.Column).Select
    xDate = Cells(3, xRange.Column).Value
    If xDate < Date + 7 Then
        MsgBox "今日から7日後までのスケジュールはクリアできません"
        Exit Sub
    End If
    If MsgBox(xDate & "以降のスケジュールを消して良いですか。", vbYesNo) <> vbYes Then Exit Sub

    Application.ScreenUpdating = False

    MaxRow = Range("B" & Rows.Count).End(xlUp).Row
    Set regAA2 = Cells(2, "AA")
    Set myRange = regAA2.Offset(3, 5).Resize(MaxRow - 4, 67)

    For Each xRange In myRange
        If xRange.Font.ColorIndex <> 3 Then    '赤
            If Cells(3, xRange.Column) >= xDate Then
                xRange.ClearContents
            End If
        End If
    Next xRange
 End Sub

 '''スケジュール表には、前月末5日、当月、来月の日付けがある
 Sub Sh1_4三ヶ月のスケジュール表に当直を記入の予備動作()
    Dim i As Long, j As Long, k As Long, n As Long
    Dim xRow As Long, MaxRow As Long, iMember As Long
    Dim Ws As Worksheet
    Dim myRange As Range, xRange As Range, regAA2 As Range
    Dim xDate As Date, myDate As Date, yDate As Date, AFDate As Date
    Dim AFColumn As Long, CLColumn As Long, xColumn As Long

    Call SetDimName_(Ws, MaxRow, iMember, AFColumn, CLColumn, regAA2, AFDate)

    Dim Buf As String
    Dim yColumn As Long

    Set myRange = regAA2.Offset(3).Resize(iMember, 67)

    Application.ScreenUpdating = False
    For j = myRange.Count To 1 Step -1
        Set xRange = myRange.Item(j)
        xColumn = xRange.Column
        Buf = xRange.Value
        '"1"の所は当直不可、"2"のところは他に当直可能者がいれば当直しない。
        If InStr(Buf, "当") Then
            If xRange.Offset(, 1).Value = "" Then xRange.Offset(, 1).Value = 1
            If xRange.Offset(, 2).Value = "" Then xRange.Offset(, 2).Value = 3
            If xRange.Offset(, 3).Value = "" Then xRange.Offset(, 3).Value = 4
            If xRange.Offset(, 4).Value = "" Then xRange.Offset(, 4).Value = 5
            If xRange.Offset(, 5).Value = "" Then xRange.Offset(, 5).Value = 6
            If xColumn > regAA2.Offset(, 5).Column Then
                If xRange.Offset(, -1).Value = "" Then xRange.Offset(, -1).Value = 1
                If xRange.Offset(, -2).Value = "" Then xRange.Offset(, -2).Value = 3
                If xRange.Offset(, -3).Value = "" Then xRange.Offset(, -3).Value = 4
            End If

            '金土日の当直を月一回に限定したい・・・月によって金土日が5日の時が有り、当直メンバーが30人以上いないと実現しない。
            xRow = xRange.Row
            If Ws.Cells(xRow, "C").Value Like "*専任*" Then
                yDate = Ws.Cells(3, xColumn).Value
                If Ws.Cells(4, xColumn).Text = "金" Or Ws.Cells(4, xColumn).Text = "土" Or Ws.Cells(4,  xColumn).Text = "日" Then
                    If Month(AFDate) = Month(yDate) Then
                        yColumn = AFColumn + Day(DateSerial(Year(AFDate), Month(AFDate) + 1, 0)) - 1
                    Else
                        yColumn = CLColumn
                    End If
                    If AFDate <= yDate Then
                        For i = xColumn + 7 To yColumn Step 7
                            If IsNumeric(Ws.Cells(xRow, i).Value) Then
                                If Ws.Cells(xRow, i).Value > 2 Then Ws.Cells(xRow, i).Value = 2
                            End If
                            If Ws.Cells(xRow, i).Value = "" Then Ws.Cells(xRow, i).Value = 2
                        Next i
                        If Month(AFDate) = Month(yDate) Then
                            yColumn = AFColumn
                        Else
                            yColumn = CLColumn - Day(DateSerial(Year(AFDate), Month(AFDate) + 2, 0))
                        End If
                        For i = xColumn - 7 To yColumn Step -7
                            If IsNumeric(Ws.Cells(xRow, i).Value) Then
                                If Ws.Cells(xRow, i).Value > 2 Then Ws.Cells(xRow, i).Value = 2
                            End If
                            If Ws.Cells(xRow, i).Value = "" Then Ws.Cells(xRow, i).Value = 2
                        Next i
                    End If
                End If
            End If
        ElseIf InStr(Buf, "休") Then
            If xRange.Offset(, -1).Value = "" Then xRange.Offset(, -1).Value = 1
        End If
    Next j

 End Sub

 Sub SetDimName_(ByRef Ws As Worksheet, ByRef MaxRow As Long, ByRef iMember As Long, ByRef AFColumn As Long, _
                ByRef CLColumn As Long, ByRef regAA2 As Range, ByRef AFDate As Date)
    Set Ws = Sheets("Sheet1")
    Set regAA2 = Ws.Cells(2, "AA")
    MaxRow = Ws.Range("B" & Rows.Count).End(xlUp).Row
    iMember = MaxRow - 4
    AFDate = Ws.Cells(3, "AF").Value
    AFColumn = Ws.Cells(3, "AF").Column
    CLColumn = Ws.Cells(3, Columns.Count).End(xlToLeft).Column
 End Sub

 Sub Sh1_02初日終了日で当直日数補正()
    Dim i As Long, j As Long, k As Long, n As Long
    Dim xRow As Long, MaxRow As Long, iMember As Long
    Dim Ws As Worksheet
    Dim myRange As Range, xRange As Range, regAA2 As Range
    Dim xDate As Date, myDate As Date, yDate As Date, AFDate As Date
    Dim AFColumn As Long, CLColumn As Long, xColumn As Long

    Call SetDimName_(Ws, MaxRow, iMember, AFColumn, CLColumn, regAA2, AFDate)

    Dim Buf As String
    Dim xAverage As Single

    Ws.Cells(5, "I").Resize(iMember).ClearContents
    Ws.Cells(5, "O").Resize(iMember).ClearContents
    Ws.Cells(5, "U").Resize(iMember).ClearContents

    For xRow = 5 To MaxRow
        If Ws.Cells(xRow, "F").Value <> "" Then
            yDate = Ws.Cells(xRow, "F").Value    'AFDate = 2/1
            If yDate >= DateSerial(Year(AFDate), Month(AFDate) + 2, 1) Then    '4/1
            ElseIf yDate >= DateSerial(Year(AFDate), Month(AFDate) + 1, 1) Then  '3/1
                Ws.Cells(xRow, "U") = 0
            ElseIf yDate >= DateSerial(Year(AFDate), Month(AFDate) - 0, 1) Then  '2/1
                Ws.Cells(xRow, "U") = 0
                Ws.Cells(xRow, "O") = 0
            Else
                Ws.Cells(xRow, "U") = 0
                Ws.Cells(xRow, "O") = 0
                Ws.Cells(xRow, "I") = 0
            End If
        End If

        '当直日数補正
        If Ws.Cells(xRow, "E").Value <> "" Then
            yDate = Ws.Cells(xRow, "E").Value
            If yDate < DateSerial(Year(AFDate), Month(AFDate) - 1, 1) Then
            ElseIf yDate < AFDate Then
                Ws.Cells(xRow, "I") = Day(yDate) - 1
            ElseIf yDate < DateSerial(Year(AFDate), Month(AFDate) + 1, 1) Then
                Ws.Cells(xRow, "I") = Day(DateSerial(Year(AFDate), Month(AFDate), 0))
                Ws.Cells(xRow, "O") = Day(yDate) - 1
            ElseIf yDate < DateSerial(Year(AFDate), Month(AFDate) + 2, 1) Then
                Ws.Cells(xRow, "I") = Day(DateSerial(Year(AFDate), Month(AFDate), 0))
                Ws.Cells(xRow, "O") = Day(DateSerial(Year(AFDate), Month(AFDate) + 1, 0))
                Ws.Cells(xRow, "U") = Day(yDate) - 1
            Else
                Ws.Cells(xRow, "I") = Day(DateSerial(Year(AFDate), Month(AFDate), 0))
                Ws.Cells(xRow, "O") = Day(DateSerial(Year(AFDate), Month(AFDate) + 1, 0))
                Ws.Cells(xRow, "U") = Day(DateSerial(Year(AFDate), Month(AFDate) + 2, 0))
            End If
        End If

        'Int(5 / (iMember - i + 1) * Ws.Cells(xRow, "I").Value + 0.5) の式の意味
        '一日の当直者数 ÷ メンバー人数 × 日数 ・・・整数四捨五入

        i = WorksheetFunction.Count(Ws.Cells(5, "I").Resize(iMember))
        If Ws.Cells(xRow, "I").Value > 0 Then
            Ws.Cells(xRow, "I").Value = Int(5 / (iMember - i + 1) * Ws.Cells(xRow, "I").Value + 0.5)
        End If

        i = WorksheetFunction.Count(Ws.Cells(5, "O").Resize(iMember))
        If Ws.Cells(xRow, "O").Value > 0 Then
            Ws.Cells(xRow, "O").Value = Int(5 / (iMember - i + 1) * Ws.Cells(xRow, "O").Value + 0.5)
        End If

        i = WorksheetFunction.Count(Ws.Cells(5, "U").Resize(iMember))
        If Ws.Cells(xRow, "U").Value > 0 Then
            Ws.Cells(xRow, "U").Value = Int(5 / (iMember - i + 1) * Ws.Cells(xRow, "U").Value + 0.5)
        End If

    Next xRow
 End Sub

 '''スケジュール表には、前月末5日、当月、来月の日付けがある
 '''それを当月末5日、来月、来来月にする・・・実行日で見ると前月末5日、当月、来月になる

 Sub Sh1_2前月末5日_当月_来月表を当月末5日_来月_来来月にする()
    Dim i As Long, j As Long, k As Long, n As Long
    Dim xRow As Long, MaxRow As Long, iMember As Long
    Dim Ws As Worksheet, xRange As Range, regAA2 As Range
    Dim xDate As Date, myDate As Date, yDate As Date, AFDate As Date
    Dim AFColumn As Long, CLColumn As Long, xColumn As Long

    Call SetDimName_(Ws, MaxRow, iMember, AFColumn, CLColumn, regAA2, AFDate)

    myDate = Date

    If regAA2.Offset(, 5).Value <> "" Then
        xDate = regAA2.Offset(, 5).Value
        xDate = DateSerial(Year(xDate), Month(xDate) + 1, 0)
    Else
        xDate = DateSerial(Year(Date), Month(Date), 0)
    End If

    Application.ScreenUpdating = False
    If Not IsDate(regAA2.Value) Then
    ElseIf myDate <= xDate Then
        Exit Sub
    Else
        '日付けをずらす際に過去二月と過去一月の実績を記録
        Ws.Cells(5, "N").Resize(iMember, 12).Copy Ws.Cells(5, "H")

        i = Day(xDate)  'i, jには、その月の日数を入れている
        j = Day(DateSerial(Year(xDate), Month(xDate) + 2, 0))
        regAA2.Offset(, i).Resize(MaxRow, j + 5).Copy regAA2
        regAA2.Offset(, j + 5).Resize(MaxRow, 67 - j).ClearContents
        regAA2.Offset(, j + 5).Resize(MaxRow, 67 - j).Font.ColorIndex = 1
    End If

    j = Day(DateSerial(Year(xDate), Month(xDate) + 2, 0))
    regAA2.Resize(3, 67).Interior.ColorIndex = 35
    regAA2.Offset(, 5).Resize(3, j).Interior.ColorIndex = 40

    xDate = xDate - 4
    For i = 0 To 66
        If xDate + i > DateSerial(Year(xDate), Month(xDate) + 3, 0) Then Exit For
        regAA2.Offset(, i).Value = xDate + i
        regAA2.Offset(1, i).Value = xDate + i
        regAA2.Offset(2, i).Value = xDate + i
        If Format(xDate + i, "aaa") = "土" Then regAA2.Offset(2, i).Interior.ColorIndex = 6
        If Format(xDate + i, "aaa") = "日" Then regAA2.Offset(2, i).Interior.ColorIndex = 3
    Next i

    Ws.Cells(3, "N").Value = Month(Date) & "月の"
 End Sub

(トラ) 2017/03/09(木) 14:38


トラ様へ
追加の要望、コード表ありがとうございます。本当にいつもいつもありがとうございます。本当に本当に心から感謝してます。
・日付自動更新なってますが、追加しても大丈夫
 →すみません、分かりました。自分でやります。

新しい標準モジュールに貼り付けて実行し確認しました。
とても凄いです、言葉がありません、、、素晴らしいです

すみませんが、条件なってないところがありまして

条件なってない
・専任職員の金土日当直のどれか2回になっている
・資格によって、防災当直だけ除いて、中央棟当直と入院当直担当する事→なれない(専門セルに打ってもなれないです)
・資格によって、入院棟当直だけ除いて、中央棟当直と防災当直担当する事→なれない(専門セルに打ってもなれないです)

他確認中です。

すみませんが、誠意がまったく感じられませんのは承知しており、さっき気付いて私のミス(条件入力)がありまして下記(修正)の通りに修正しました。

 修正
 1、上から7人目までの中(専任職員)に1人に選ばれた時は、8人目から下までの中(専任職員)に、2〜3名選ぶ、委託職員は、1人以上 → 誤
   上から7人目までの中(専任職員)に1人に選ばれた時は、8人目から下までの中(専任職員)に、1〜3名選ぶ、委託職員は、1人以上 → 正

 2、上から7人目までの中(専任職員)に2人に選ばれた時は、8人目から下までの中(専任職員)に、2〜3名選ぶ、委託職員は、1人以上 → 誤
   上から7人目までの中(専任職員)に2人に選ばれた時は、8人目から下までの中(専任職員)に、0〜3名選ぶ、委託職員は、1人以上 → 正

1の部分『2〜3名選ぶ』→『1〜3名選ぶ』です。
2の部分『2〜3名選ぶ』→『0〜3名選ぶ』です。

誠意がまったく感じられませんのは承知しており、本当に迷惑をかけて申し訳がありません、不確認だったと猛反省しております。

本当に心から感謝しております。

『修正』と『条件なってない』の件、お手数ですがよろしくお願い致します。

本当に迷惑をかけて申し訳がありません
(SinNeo) 2017/03/09(木) 18:19


 ・専任職員の金土日当直のどれか2回になっている・・・解っています。これは、実行するたびに変わるので10回くらい実行 すると一回くらい成功する・・・これ以上の改良は、無理です。

 上から7人目までの中(専任職員)に1人に選ばれた時は、8人目から下までの中(専任職員)に、1〜3名選ぶ、委 託職員は、1人以上 → 正 
 上から7人目までの中(専任職員)に2人に選ばれた時は、8人目から下までの中(専任職員)に、0〜3名選ぶ、委 託職員は、1人以上 → 正 

 これは、そういう風に作ってあります。
上から7人目・・・上から10人

 ・資格によって、防災当直だけ除いて、中央棟当直と入院当直担当する事→なれない(専門セルに打ってもなれないです) 
 ・資格によって、入院棟当直だけ除いて、中央棟当直と防災当直担当する事→なれない(専門セルに打ってもなれないです) 
 これは、全員の資格保有状況と責任者とそれ以外の人の関係、専任職員の上7人それ以外の関係、などを詳しく説明してください。そしてそれをどういう風に入力したかをわかるように説明してください。
 いずれにしても、資格所有者が2人以上いると思い通りにいかないと思います。

(トラ) 2017/03/09(木) 20:57


トラ様へ
返信遅れて申し訳がありません。
いつもいつもありがとうございます。
誠意がまったく感じられませんのは承知しており、本当に迷惑をかけて申し訳がありません、

・専任職員の金土日当直のどれか2回になっている
 →分かりました。ありがとうございます。

・『上から7人目・・・上から10人』っていう事は
 →上から10人目までの中(専任職員)に1人に選ばれた時は、8人目から下までの中(専任職員)に、1〜3名選ぶ、委 託職員は、1人以上 → 正
  上から10人目までの中(専任職員)に2人に選ばれた時は、8人目から下までの中(専任職員)に、0〜3名選ぶ、委 託職員は、1人以上 → 正
  って感じですか?

・資格によって、防災当直だけ除いて、中央棟当直と入院当直担当する事→なれない(専門セルに打ってもなれないです)
・資格によって、入院棟当直だけ除いて、中央棟当直と防災当直担当する事→なれない(専門セルに打ってもなれないです)
 →すみません。日本語不足ですみません。下記の通り説明します。

  基本
  中央棟は、資格なくても誰でも大丈夫です。
  入院棟は、資格なくても誰でも大丈夫です。(但し、新人は研修してから) 
  防災当直は、防災関係の資格必要で、持ってる人、持ってない人居ます。

  ■資格によって、防災当直だけ除いて、中央棟当直と入院当直担当する事
   →専任職員の上7人とか関係なく防災関係の資格が持ってない人 (但し責任者だけは中央棟当直担当する)

  ■資格によって、入院棟当直だけ除いて、中央棟当直と防災当直担当する事
   →専任職員の上7人とか関係なく防災関係の持ってる人

  ■『どういう風に入力したいかをわかるように説明』

  修正前

   B   C   D   E   F
 1 名前  所属  専門  初日  終了日

  修正後(希望)

   B   C   D   E   F   G   H   
 1 名前  所属  中央棟 入院棟 防災  初日  終了日
 2 1       ○      
 3 2       ○       ○
 4 3       ○   ○   ○

  こんな感じでいいなと思います。

・条件なってない
 専任職員7人(10人)から下まで、毎週同じメンバーになっている(何回もやっても同じ)
 専任職員8人(11人)から下まで、毎週同じメンバーになっている(何回もやっても同じ)
 出来れば、毎週同じメンバーだけは控えたいです。

他確認中です。

本当に心から感謝しております。が、誠意がまったく感じられませんのは承知しており、本当に迷惑をかけて申し訳がありません。
日本語不足で話を通じない事をあると思いますが、宜しくお願いします。
お手数ですが、宜しくお願い致します。
(SinNeo) 2017/03/13(月) 15:02


SinNeoさんへ

 今日書き込んだ投稿と、いままで書き込んだ投稿を比べて、資格や責任者の説明を書き直してください。

 セルの配置変更は出来ません。
 セルにどのように書き込んだかを説明してください。

 ・出来れば、毎週同じメンバーだけは控えたいです。
  これは正常なコードの動きです。
 なぜなら、当直間隔を各人均等にすると、当然そのように成ります。
(トラ) 2017/03/13(月) 19:34

トラ様へ
1週間遅れて申し訳がありません。いつも本当にありがとうございます

  中央棟は、資格なくても誰でも大丈夫です。
  入院棟は、資格なくても誰でも大丈夫です。(但し、新人は研修してから) 
  責任者は、監視必要で中央棟にいる事
  防災当直は、防災関係の資格必要で、持ってる人、持ってない人居ます。
  ■資格によって、防災当直だけ除いて、中央棟当直と入院当直担当する事
   →専任職員の上7人とか関係なく防災関係の資格が持ってない人 (但し責任者だけは中央棟当直担当する)
  ■資格によって、入院棟当直だけ除いて、中央棟当直と防災当直担当する事
   →専任職員の上7人とか関係なく防災関係の持ってる人

『セルにどのように書き込んだかを説明してください。』
  →「防災 中央棟」・「入院棟 中央棟」と打ちましたが、成ってないです。

『毎週同じメンバーだけは控えたいです』
  →そうですか、、上級専任居るとこうなるですよね、、

本当に心から感謝しております。が、誠意がまったく感じられませんのは承知しており、本当に迷惑をかけて申し訳がありません。
日本語不足で話を通じない事をあると思いますが、宜しくお願いします。
お手数ですが、宜しくお願い致します。

(SinNeo) 2017/03/20(月) 12:49


トラ様へ

修正しました。宜しくお願い致します。

遅れて申し訳がありません。いつも本当にありがとうございます
  中央棟は、資格なくても誰でも大丈夫です。
  入院棟は、資格なくても誰でも大丈夫です。(但し、新人は研修してから) 
  責任者は、監視必要で中央棟にいる事
  防災当直は、防災関係の資格必要で、持ってる人、持ってない人居ます。
  ■資格によって、防災当直だけ除いて、中央棟当直と入院当直担当する事
   →専任職員の上7人とか関係なく防災関係の資格が持ってない人 (但し責任者だけは中央棟当直担当する)
  ■資格によって、入院棟当直だけ除いて、中央棟当直と防災当直担当する事
   →専任職員の上7人とか関係なく防災関係の持ってる人
『セルにどのように書き込んだかを説明してください。』
  →「防災センター 中央棟」・「入院棟 中央棟」と打ちましたが、成ってないです。
『毎週同じメンバーだけは控えたいです』
  →そうですか、、上級専任居るとこうなるですよね、、
本当に心から感謝しております。が、誠意がまったく感じられませんのは承知しており、本当に迷惑をかけて申し訳がありません。
日本語不足で話を通じない事をあると思いますが、宜しくお願いします。
お手数ですが、宜しくお願い致します。
(SinNeo) 2017/03/23(木) 14:08


トラ様へ
1週間本当に遅れて申し訳がありません。猛反省してます。
(SinNeo) 2017/03/30(木) 17:35

コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.