エクセル部品表のVBAについてご教示願います

Question

過去、別に質問させていただいた件と同様です。
図の②④⑤を自動化するエクセルファイルを作りたいです（ファイルが見辛く恐縮です）。
以前はセルに関数を入れない、という条件が抜けていたために②を条件付き書式にして④をセルの
関数で行うようご助言いただきましたが、セルにはメモを入れたいので関数は入れたくないです。
となると、VBAの出番ですがプログラミングに疎いものでお力添えいただければと思います。
⑤の転記は「作業１－１　部品１」でもOKです。
どうぞよろしくお願い致します。

tatsu99 · Accepted Answer

以下のマクロを標準モジュールに登録してください。
前回のマクロは破棄してください。
文字数がオーバーしたので下記URLに書き込みました。下記からコピペしてください。
http://climbi.com/b/9836/0

tatsu99 · Answer

No6です。
以下の確認をお願いします。

１）６行～部品数のある行の直前の行のC列～I列は、添付図の黄色の部分は、結合セルでなく、単独のセルと
理解しましたが、間違いないでしょうか。（図では、結合セルでないことを強調する単に２重の罫線を入れています）

２）作業の登録は１行に１作業のみとしますがそれでよろしいでしょうか。
同一行に複数作業があった場合は、エラーとします。
添付図のように作業２－４と作業２－５があった場合、エラーになります。（緑で囲まれた部分）

３）J列以降は、以下のレイアウトで間違いないでしょうか。
開始　：J
終了　：K
部品１：L
～
部品４：O
1/1　 ：P
～
12/31 ：NP

以上、ご確認をお願いいたします。

tatsu99 · Answer

No5です。
M7の年は2017~2099が正常値です。・・・は
M4の年は2017~2099が正常値です。・・・の誤りです。訂正します。（マクロの内容に変更はありません）

tatsu99 · Answer

No3,No4です。

No3,No4での確認事項に基づきマクロを作成してあります。
部品の合計行は可変行としています。7行以降でC列の値が”部品数”である行を部品の合計行とします。
（この行がないとエラーになります）
M7の年は2017~2099が正常値です。
最初にM列～NN列までクリアします。（NNは閏年を考慮してます）
不明点、不具合などあれば、補足ください。
標準モジュールに登録して実行してください。
--------------------------------------------------
Option Explicit
Public Sub スケジュール作成()
Dim dicT As Object
Dim sh1, sh2 As Worksheet
Dim row, ttlrow, maxrow, col, tcol As Long
Dim yyyy As Long
Dim i As Long
Dim key, key1, key2 As String
Dim sday, eday, wday As Date
Dim year_1stday As Date
Set dicT = CreateObject("Scripting.Dictionary")
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
yyyy = sh1.Cells(4, "M").Value
'年のチェック
If yyyy < 2017 Or yyyy > 2099 Then
MsgBox ("M4の年が不正：" & sh1.Cells(4, "M").Text & vbLf & "処理を打ち切ります")
Exit Sub
End If
year_1stday = DateSerial(yyyy, 1, 1)
'部品数の行を決定
maxrow = sh1.Cells(Rows.Count, "C").End(xlUp).row 'C列の最終行
ttlrow = 0
For row = 7 To maxrow
If sh1.Cells(row, "C").Value = "部品数" Then
ttlrow = row
Exit For
End If
Next
If ttlrow = 0 Then
MsgBox ("部品数の合計行がありません" & vbLf & "処理を打ち切ります")
Exit Sub
End If
'データ設定領域をクリア
sh1.Range("M6:NN" & ttlrow).Clear
'Sheet2の作業＋部品の組み合わせでその数を記憶する
maxrow = sh2.Cells(Rows.Count, "A").End(xlUp).row
For row = 2 To maxrow
key = sh2.Cells(row, 1).Value & "|" & sh2.Cells(row, 2).Value
dicT(key) = sh2.Cells(row, 3).Value
Next
'作業分繰り返す
For row = 6 To ttlrow - 1
'作業なしなら終了
If sh1.Cells(row, "C").Value = "" Then Exit For
sday = sh1.Cells(row, "G").Value
eday = sh1.Cells(row, "H").Value
'開始日が当年より小さいなら当年の1月1日に設定
If Year(sday) > yyyy Then
sday = DateSerial(yyyy, 1, 1)
End If
'終了日が当年より大きいなら当年の12月31日に設定
If Year(eday) > yyyy Then
eday = DateSerial(yyyy, 12, 31)
End If
If sday > eday Then
MsgBox (row & "行の開始日が終了日より大きい:" & sh1.Cells(row, "G").Text & "と" & sh1.Cells(row, "G").Text & vbLf & "処理を打ち切ります")
Exit Sub
End If
'開始～終了までを開始(G列)の色で埋める
For wday = sday To eday
col = 13 + wday - year_1stday
Cells(row, col).Interior.Color = Cells(row, "G").Interior.Color
Next
'部品分繰り返す
For col = 9 To 12
If sh1.Cells(row, col).Value <> "" Then
wday = sh1.Cells(row, col).Value
If wday < sday Or wday > eday Then
MsgBox (row & "行 " & Chr(Asc("A") + col - 1) & "列の日付不正:" & sh1.Cells(row, col).Text & vbLf & "処理を打ち切ります")
Exit Sub
End If
'作業名＋部品名
key1 = sh1.Cells(row, "C").Value
key2 = sh1.Cells(5, col).Value
key = key1 & "|" & key2
If dicT.exists(key) = False Then
MsgBox (row & "行 " & Chr(Asc("A") + col - 1) & "列の日付対応の部品数未登録:" & sh1.Cells(row, col).Text & vbLf & key1 & "と" & key2 & "の組み合わせなし" & vbLf & "処理を打ち切ります")
Exit Sub
End If
'部品名設定
tcol = 13 + wday - year_1stday
sh1.Cells(row, tcol).Value = sh1.Cells(5, col).Value
'部品数計の設定
sh1.Cells(ttlrow, tcol).Value = sh1.Cells(ttlrow, tcol).Value + dicT(key)
End If
Next
Next
MsgBox ("処理完了")
End Sub
------------------------------------------

tatsu99 · Answer

No3です。補足ありがとうございました。
例では、作業名は6行～１３行に記述し、部品数の合計を１４行に記述していますが、
スケジュールが１年間だとすると、2月、３月と増えたときに、
作業名を記述する行が足りなくなると思います。
その為、
１案）2月になった場合は、1月の作業欄を消して、そこへ2月の日付を割り当てるのでしょうか。
（その場合、マクロを実行すると、1月のぶんは消去されます。）（部品数合計の行は14行固定とする）
２案）1月分は消さずに、下の行へ2月分を記入する。そうすると、2行～13行では足りないので、
部品数の合計を記述する行は、下へ移動する。（部品数合計の行は可変とする）

1案、2案のどちらを想定されていますか。それとも、他の案を想定されていれば、その旨補足ください。

tatsu99 · Answer

補足要求です。
１）カレンダーの日付は、M列から開始して１か月間ですか？それとも1年間ですか。
２）1か月間だとすると2月になったら、M5は2/1になるのですか。
３）開始、終了が月またがりすることはありますか。（カレンダーの日付が１か月の場合です）
　　例　開始　1/1　終了　2/11
４）②の作業で背景を色で塗りつぶすとき、色を選択したいということですが、開始（G列）に色を設定して
　　おき、その色を採用するというでも良いですか。（添付図参照 赤線で囲んだ部分）
５）部品表は、別シートに添付図のようなレイアウトで作成してあるという前提で良いでしょうか。
　　1行目：見出し行
　　A列：作業名
　　B列：部品名
　　C列：部品数
　　列について変えたい要望があれば、その旨、提示ください。
６）各シートのシート名ですが、以下の前提で良いですか。
スケジュールのかかれたシートのシート名：Sheet1
部品表のシート名：Sheet2
シート名を変えたい場合は、その旨、補足ください。

yokomaya · Answer

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim cl As Range
    If Not Intersect(Target, Range("I5:L8")) Is Nothing Then
        Set cl = Range("M5:AQ5").Find(Target)
        If cl Is Nothing Then
            MsgBox "入力された日付(" & Target.Text & ")は範囲外です"
        Else
            Application.EnableEvents = False
            Cells(Target.Row, cl.Column).Formula = Cells(5, Target.Column)
             Application.EnableEvents = True
        End If
        
    End If
End Sub

上記をシート名のタグを右クリックでコードを表示で
出てくる窓に張り付ければ、表示はされます。
本当は修正に備えて消す処理も必要だけど
そこまではまだです。

yokomaya · Answer

全然難しくはないですが、今出先なのでひとつだけ確認させて下さい。
メモを入れると言うお話ですがメモといってもその小さなセル、
コメントで入力して常時表示にする方が吹き出し風に自由に位置を移動させられますし、なにより広く取れますから便利じゃないでしょうか？

エクセル部品表のVBAについてご教示願います

以下のマクロを標準モジュールに登録してください。

No6です。

No5です。

No3,No4です。

No3です。

補足要求です。

Private Sub Worksheet_Change(ByVal Target As Range)

全然難しくはないですが、今出先なのでひとつだけ確認させて下さい。

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング