VBAで別シートの内容を参照して、欠落している時刻があれば行追加したい

Question

サンプル

https://docs.google.com/spreadsheets/d/e/2PACX-1vSXvCjZB5eIS_ojLOxKiCsf7rfH4qDWfXDMko6KnkWVRfAn9CIMN3C2DEipChB1g2VGpLiqLdY6vmTT/pubhtml

前提

• イベントリストシート(EventListsシート)には、曜日別、開始時刻別のイベント一覧が記載されています。
• マスターシート(Masterシート)には、日付別のイベント一覧が記載されています。
• マスターシート(Masterシート)に入るデータは、一か月分のみです
• 開始曜日は月曜日とします
• 曜日の区切りは 05:00 ～ 28:59 とします

やりたいこと

Masterシートについて、EventListsシートに存在しない時刻があれば、行追加して、対象時刻を埋め込みたいです
サンプルURLにある、期待結果シートのような形にしたいです。(背景色はつかなくていいです)

現状、Masterシートは以下のような並びですが

イベント日	曜日	開始時刻	種別
20220901	木	502	B
20220901	木	502	B
20220901	木	502	A
20220901	木	502	A
20220901	木	502	A
20220901	木	502	A
20220901	木	510	A
20220901	木	510	A
20220901	木	606	A
20220901	木	606	A

EventListsシートのC列 開始時間を見ると、5:00からのイベントがありますので、
以下のように、先頭に行追加したいです

種別も見分けがつきやすいように、ADDとつけたいです

イベント日	曜日	開始時刻	種別
20220901	木	500	ADD
20220901	木	502	B
20220901	木	502	B
20220901	木	502	A
20220901	木	502	A
20220901	木	502	A
20220901	木	502	A
20220901	木	510	A
20220901	木	510	A
20220901	木	606	A
20220901	木	606	A

現在の実装

Sub appendPositionToMaster()
  Dim ws As Worksheet
  Dim ws2 As Worksheet
  Dim lastRowNum As Long
  Dim lastRowNum2 As Long
  Dim i As Integer
  Dim j As Integer
  Dim weekName As String
  Dim startTime
  Dim weekName2 As String
  Dim startTime2

  Set ws = Worksheets("EventLists")
  Set ws2 = Worksheets("Master")

  ' A列の最終行番号を取得
  lastRowNum = ws.Range("A" & Rows.Count).End(xlUp).row
  lastRowNum2 = ws2.Range("A" & Rows.Count).End(xlUp).row

  ' EventListsシート 行単位でループ
  For i = 2 To lastRowNum
    ws.Activate

    ' L列(fix_week_name) の値を取得
    weekName = Cells(i, 12).Value
    ' M列(fix_start_time) の値を取得
    startTime = Cells(i, 13).Value

    ' M列(fix_start_time) の値をセミコロンなしの数値に変換する(0.208333333 -> "5:00" -> 500)
    startTime = Val(Format(startTime, "hmm"))

    ' Masterシート 行単位でループ
    For j = 2 To lastRowNum2
      ws2.Activate

      ' B列(曜日) の値を取得
      weekName2 = Cells(j, 2).Value
      ' C列(開始時刻) の値を取得
      startTime2 = Cells(j, 3).Value

      If weekName2 = "" Then Exit For

      ' C列(開始時刻) の値を数値に変換する("502" -> 502)
      startTime2 = Val(startTime2)

      ' 曜日が同じの時
      ' EventListsの開始時刻がMasterシートの開始時刻よりも早い時
      If weekName = weekName2 And startTime > startTime2 Then
        MsgBox "Hit"
        Rows(j).Insert
        Exit For
      End If
    Next j
  Next i
End Sub

困っていること

• VBAで、行追加して、任意の値を代入する方法がわからないです
• ループ処理の適切な条件設定がわからないです

どのようにすれば、やりたいことが達成できますでしょうか。
VBAは経験が少なくてよくわからないです。

Comments

[hatena19]

Masterシートは、日付、開始時刻の昇順になってますか。
また、エクセルのバージョンはなんでしょうか。

[qwe001]

日付、開始時刻の昇順です。ExcelのバージョンはMicrosoft® Excel® 2019 MSO (バージョン 2111 ビルド 16.0.14701.20204) 32 ビット です。よろしくお願いいたします。

[tatsu99]

Masterに行を追加するのではなく、別のシートにMatserの行とEventListsの必要な行を追記する方法でも良いですか。最終的にMasterのシートが欲しいなら、Materシートを削除して、別のシートをMasterにRenameすればよいかと思います。
別のシートに出力するのはMatserのA列～H列までです。
EventListsの出力項目も、MatserのA列～H列に該当する列になります。
EventListsのP列を作業用に使用します。
（M列時刻(5:00)を数値(500）に変換したものをP列に書き込みます）
上記で良ければ、対応可能です。

[qwe001]

@tatsu99 ご連絡ありがとうございます。それで大丈夫です。Masterシート自体、私が他社から提供されたオリジナルのシートを作業しやすいように型変換などをしたシートですので。(もともとのシートは全ての値が文字列形式になっていて値の比較ができませんでした)
よろしくお願いいたします。

Answer 1

空のシート："出力"　を作成してから実行してください。
そのほかは「質問への追記・修正の依頼」で記述した通りです。
不明点があれば、補足してください。

Option Explicit
Public Sub イベント追加()
    Dim ws As Worksheet         'Event Lists
    Dim ws2 As Worksheet        'Master
    Dim ws3 As Worksheet        '出力
    Dim lastRowNum As Long      'Event Lists最終行
    Dim lastRowNum2 As Long     'Master 最終行
    Dim weekName As String      '曜日
    Dim PrevName As String      '前回曜日

    Dim startTime As Variant    '開始時刻(h:mm)(Event Lists)
    Dim startTimeL As Long      '開始時刻(hmm)(Event Lists)
    Dim startTimeL2 As Long     '開始時刻(hmm)(Master)
    Dim MasterDate As Long      '日付(Master)
    Dim PrevDate As Long        '前回日付(Master)
    Dim weekName2 As String
    Dim key As Variant
    Dim wrow As Long            '行番号（EventLists）
    Dim wrow2 As Long           '行番号（Master）
    Dim wrow3 As Long           '行番号（出力）
    Dim strow_dic As Object     '開始行番号（曜日単位）
    Dim enrow_dic As Object     '終了行番号（曜日単位）
    Dim st_row As Long          '開始行番号（EventLists）
    Dim en_row As Long          '終了行番号（EventLists）
    Dim cur_row As Long         '処理中行番号（EventLists）
    Set strow_dic = CreateObject("Scripting.Dictionary")
    Set enrow_dic = CreateObject("Scripting.Dictionary")
    Set ws = Worksheets("EventLists")
    Set ws2 = Worksheets("Master")
    Set ws3 = Worksheets("出力")
    ' A列の最終行番号を取得
    lastRowNum = ws.Range("A" & Rows.Count).End(xlUp).Row
    lastRowNum2 = ws2.Range("A" & Rows.Count).End(xlUp).Row
    ' EventListsシート 行単位でループ
    PrevName = ""
    For wrow = 2 To lastRowNum
        ' L列(fix_week_name) の値を取得
        weekName = ws.Cells(wrow, "L").Value
        ' M列(fix_start_time) の値を取得
        startTime = ws.Cells(wrow, "M").Value
        ' M列(fix_start_time) の値をセミコロンなしの数値に変換する(0.208333333 -> "5:00" -> 500)
        If startTime < 1 Then
            startTimeL = Val(Format(startTime, "hmm"))
        Else
            startTimeL = Val(Format(startTime - 1, "hmm")) + 2400
        End If
        '曜日変わり時に開始行番号を設定
        If weekName <> PrevName Then
          strow_dic(weekName) = wrow
        End If
        '終了行番号を設定
        enrow_dic(weekName) = wrow
        '開始時刻（数値）を設定
        ws.Cells(wrow, "P").Value = startTimeL
        '前回曜日を保存
        PrevName = weekName
    Next
    '出力シートクリア＆見出し設定
    ws3.Cells.ClearContents
    wrow3 = 1
    wrow2 = 1
    Call put_master(ws2, wrow2, ws3, wrow3)     'Matser1行出力
    ' Masterシート 行単位でループ
    PrevDate = 0
    en_row = -1
    cur_row = 0
    For wrow2 = 2 To lastRowNum2
        ' A列の日付を取得
        MasterDate = ws2.Cells(wrow2, "A").Value
        ' B列(曜日) の値を取得
        weekName2 = ws2.Cells(wrow2, "B").Value
        ' C列(開始時刻) の値を取得
        startTimeL2 = ws2.Cells(wrow2, "C").Value
        '日付変更時の処理
        If PrevDate <> MasterDate Then
            '残っているEvent行を出力する
            Call flush_event(PrevDate, ws, cur_row, en_row, ws3, wrow3)
            st_row = strow_dic(weekName2)
            en_row = enrow_dic(weekName2)
            cur_row = st_row
        End If
        'EventListsの当日分が未処理ならEventListsを処理
        If cur_row <= en_row Then
            startTimeL = ws.Cells(cur_row, "P").Value
            'Masterの時刻>EventListsの時刻であるEventListsを全て出力
            If startTimeL2 >= startTimeL Then
                Call put_past_event(MasterDate, startTimeL2, ws, cur_row, en_row, ws3, wrow3)
            End If
        End If
        'Matser1行出力
        Call put_master(ws2, wrow2, ws3, wrow3)
        '前回日付を保存
        PrevDate = MasterDate
    Next
    '残っているEvent行を出力する
    Call flush_event(PrevDate, ws, cur_row, en_row, ws3, wrow3)
    MsgBox ("完了")
End Sub
'Master１行出力
Private Sub put_master(ws2 As Worksheet, wrow2 As Long, ws3 As Worksheet, wrow3)
    ws3.Range("A" & wrow3).Resize(, 8).Value = ws2.Range("A" & wrow2).Resize(, 8).Value     'A～H
    wrow3 = wrow3 + 1
End Sub
'残Event Lists 出力
Private Sub flush_event(ByVal msdate As Long, ws As Worksheet, cur_row As Long, en_row As Long, ws3 As Worksheet, wrow3 As Long)
    Dim wrow As Long
    For wrow = cur_row To en_row
        Call put_event(msdate, ws, wrow, ws3, wrow3)   '1行出力
    Next
End Sub
'Master時刻より小さい時刻のEvent Listsを出力（MasterとEventListsの時刻が同じ場合は出力しない）
Private Sub put_past_event(ByVal msdate As Long, ByVal mstime As Long, ws As Worksheet, cur_row As Long, en_row As Long, ws3 As Worksheet, wrow3 As Long)
    Dim st_time As Long
    Do
        If cur_row > en_row Then Exit Do
        st_time = ws.Cells(cur_row, "P").Value
        If mstime < st_time Then Exit Do
        If mstime > st_time Then
            Call put_event(msdate, ws, cur_row, ws3, wrow3)   '1行出力
        End If
        cur_row = cur_row + 1
    Loop
End Sub

'Event Lists1行出力
Private Sub put_event(ByVal msdate As Long, ws As Worksheet, ByVal wrow As Long, ws3 As Worksheet, wrow3 As Long)
    ws3.Cells(wrow3, "A").Value = msdate                     '日付
    ws3.Cells(wrow3, "B").Value = ws.Cells(wrow, "L").Value  '曜日
    ws3.Cells(wrow3, "C").Value = ws.Cells(wrow, "P").Value  '時刻
    ws3.Cells(wrow3, "D").Value = "ADD"                      '種別
    ws3.Range("E" & wrow3).Resize(, 4).Value = ws.Range("F" & wrow).Resize(, 4).Value       'culumn1-4
    wrow3 = wrow3 + 1
End Sub

Comments

[qwe001]

ありがとうございます！！まだ精査できてませんが、望んでいる形をほぼ100%実現できているように思えます。曜日名が0になっている(EventListsシートのP列を上書きしているためと思われる)などの課題がありますが、このあたりは私でも調整できそうです。引き続きデータ検証して、問題なさそうならBAをつけさせて頂きます。

[tatsu99]

>曜日名が0になっている(EventListsシートのP列を上書きしているためと思われる)
シート：出力の曜日名が０になっているということでしょうか。
こちらでは、そのような現象は発生していません。
参考までに、こちらで使用したEventListsとMasterです。
Masterはテストのため、いろいろ変えています。
https://firestorage.jp/download/efb8516e571703acefa822702ff90384642df73d

[tatsu99]

すみません。
一部訂正します。
'Event Lists1行出力
Private Sub put_event(ByVal msdate As Long, ws As Worksheet, ByVal wrow As Long, ws3 As Worksheet, wrow3 As Long)
ws3.Range("A" & wrow3).Resize(, 2).Value = ws.Range("A" & wrow).Resize(, 2).Value '日付と曜日
ws3.Cells(wrow3, "A").Value = msdate '日付
ws3.Cells(wrow3, "B").Value = ws.Cells(wrow, "L").Value '曜日
ws3.Cells(wrow3, "C").Value = ws.Cells(wrow, "P").Value '時刻
ws3.Cells(wrow3, "D").Value = "ADD" '種別
ws3.Range("E" & wrow3).Resize(, 4).Value = ws.Range("F" & wrow).Resize(, 4).Value 'culumn1-4
wrow3 = wrow3 + 1
End Sub
の
ws3.Range("A" & wrow3).Resize(, 2).Value = ws.Range("A" & wrow).Resize(, 2).Value '日付と曜日
ws3.Cells(wrow3, "A").Value = msdate '日付
は不要です。
この行を削除してください。
回答のほうも修正しておきます。

[qwe001]

正しく、私が求めていた通りの出力が得られました。本当にありがとうございました。一点、訂正がありまして。

'開始時刻（数値）を設定
ws.Cells(wrow, "P").Value = startTimeL

こちらは ws.Cells(wrow, "Q").Value = startTimeL にします。
同様に、他にP列を参照しているものも Q列に変更します。
P列にある値は、現在セルが上のセルと同じ曜日かどうかを判定してインデックス番号を生成し、L列の曜日名を生成するのに使用します。
現在のVBAコードのままですと、出力シートに追加した行の、B列 曜日名が0になるので、それを調整すれば、期待動作になりました。
明日までに納品しなければいけなかったので、間に合って本当に助かりました…！！

[tatsu99]

P列は使用されている列だったのですね。空いている列と勘違いしました。失礼しました。
期待した結果になってなによりです。

Answer 2

サンプルコードを書きかけたのですが、結構、複雑なコードになりそうです。
とりあえず、ヒントだけ出しておきます。

---

.Activate でシートのアクティブを切り替えるのはやめましょう。処理が遅くなるだけです。
ws、ws2 とシートを変数に代入してますので、それを使えばアクティブでないシートでも処理できます。
下記のような感じです。

    ' L列(fix_week_name) の値を取得
    weekName = ws.Cells(i, 12).Value

---

行挿入する場合は、挿入した分だけそれ以降の行がずれていきます。最終行もずれます。
ですので、For Next ではなく、Do Loop を使ってセルが空白になるまで繰り返すという処理にした方がいいでしょう。あるいは、For Next を使うなら、最終行から前へ移動しながら処理をするというようにします。

---

行挿入して、その行に値を代入する方法は、下記のような感じで。

        ws2.Rows(j).Insert
        ws2.Cells(j, "B").Value = weekName 
        ws2.Cells(j, "C").Value = startTime
        ws2.Cells(j, "D").Value = "ADD"

Comments

[qwe001]

ヒントを出して頂きありがとうございます。引き続き私も試行錯誤していますが、思ってたより複雑で難航しています。。 `ws.Activate` については、動作OKになったら `Application.ScreenUpdating = false/true` をコードの上下につけて処理速度低下を防ぐ予定でした。でも、Withステートメントを使えばシートをアクティブにしなくてもセル操作できるんですね。以後、VBA開発するときはそれを使おうと思います。