【エクセルVBA】別シートからカレンダーに行事を転記する方法

2019年8月5日
2019年8月31日
カレンダーアプリ
VBA, データ転記, ｶﾚﾝﾀﾞｰ

カレンダーアプリ

みなさん、こんにちはケンケンです。

エクセルVBAを使ってカレンダー作りをしています。

今回は、別シートで管理しているイベント一覧から行事内容を転記する方法をご紹介します。

データ転記は実務ではかかせない作業なので、これを機にマスターしちゃいましょう。

前回の復習はこちらからどうぞ。

1 別シートからカレンダーに行事を転記する
2 まとめ

別シートからカレンダーに行事を転記する

カレンダーを作るコードは以前書いたものを使います。

Sub hiduke_rensyu10()
    Dim sday '最初の日という意味
    Dim ntuki '次の月を格納
    Dim stuki '翌月の最初の日を格納
    Dim lday '最後の日という意味
    
    ntuki = Range("D2").Value + 1
    If ntuki = 13 Then
        ntuki = 1
        sday = CDate(Range("C2") & "/" & Range("D2") & "/" & "1")
        stuki = CDate(Range("C2") + 1 & "/" & ntuki & "/" & "1")
        lday = stuki - 1
        
    Else
        sday = CDate(Range("C2") & "/" & Range("D2") & "/" & "1")
        stuki = CDate(Range("C2") & "/" & ntuki & "/" & "1")
        lday = stuki - 1
        
    End If
    
    
    Dim cnt '書き出し先のカウント変数
    cnt = 2
    Do While sday <= lday
        Range("A" & cnt).Value = sday
        sday = DateAdd("d", 1, sday)
        cnt = cnt + 1
    Loop
End Sub

Sub hiduke_rensyu10()

Dim sday '最初の日という意味

Dim ntuki '次の月を格納

Dim stuki '翌月の最初の日を格納

Dim lday '最後の日という意味

ntuki = Range("D2").Value + 1

If ntuki = 13 Then

ntuki = 1

sday = CDate(Range("C2") & "/" & Range("D2") & "/" & "1")

stuki = CDate(Range("C2") + 1 & "/" & ntuki & "/" & "1")

lday = stuki - 1

Else

sday = CDate(Range("C2") & "/" & Range("D2") & "/" & "1")

stuki = CDate(Range("C2") & "/" & ntuki & "/" & "1")

lday = stuki - 1

End If

Dim cnt '書き出し先のカウント変数

cnt = 2

Do While sday <= lday

Range("A" & cnt).Value = sday

sday = DateAdd("d", 1, sday)

cnt = cnt + 1

Loop

End Sub

下図のように年と月を指定してコードを実行し、2020年７月を表示させておきましょう。

シートを初期化するコードを書こう

さて、これから転記するためのコードを書いていくのですが、その前にシートを初期化するコードを書きます。

初期化とはデータをまっさらな状態に戻すことを言い、今回は、A列とB列の文字列を消します。

hiduke_rensyu10プロシージャに以下のように追加します。

    stuki = CDate(Range("C2") & "/" & ntuki & "/" & "1")
        lday = stuki - 1
        
    End If
 ------------------この下追加-----------------------   
    Range("A:B").ClearContents '初期化①
    Range("A1").Value = "日付" '②
    Range("B1").Value = "主な行事" '②
 -----------------この上追加-----------------------     
    Dim cnt '書き出し先のカウント変数
    cnt = 2
    Do While sday <= lday

stuki = CDate(Range("C2") & "/" & ntuki & "/" & "1")

lday = stuki - 1

End If

------------------この下追加-----------------------

Range("A:B").ClearContents '初期化①

Range("A1").Value = "日付" '②

Range("B1").Value = "主な行事" '②

-----------------この上追加-----------------------

Dim cnt '書き出し先のカウント変数

cnt = 2

Do While sday <= lday

コードの解説をします。

①セルの値を削除したい場合は、ClearContentsメソッドを使います。

Range(“A:B”).ClearContentsのようにRangeオブジェクトの後にメソッドを書きます。

Range(“A:B”)はA列とB列のことですから、A列とB列の値を削除する、という意味ですね。

ちなみに、似たメソッドでClearメソッドがありますが、これは、値だけでなく書式などすべてが初期化（削除）されます。

今回は、値のみを消したいのでClearContentsを使いました。

②A列とB列に見出しをつけます。

A１セルに日付、B１セルに主な行事として表示されています。

当然①の範囲指定でA1セルとB1セルの値を消去しなければ、②のコードは不要になります。

お好みで使ってください。

初期化するコードは重要なので、意識的に使えるようにしてください。

これを忘れるとデータがどんどん上書きされてしまい、何が正しいデータか分からなくなってしまいます。

シート名は明確に分けておこう

続きまして、転記する方法をご紹介します。

これも前回書いたコードを使って応用していきます。

Sub kensaku_offset1()
    Dim cnt
    Dim kensakucnt
    For kensakucnt = 2 To 4
        For cnt = 2 To 6
            If Range("A" & cnt).Value = Range("F" & kensakucnt).Value Then
                Range("G" & kensakucnt).Value = Range("A" & cnt).Offset(0, 1).Value
                Range("H" & kensakucnt).Value = Range("A" & cnt).Offset(0, 2).Value
            End If
        Next
    Next
End Sub

Sub kensaku_offset1()

Dim cnt

Dim kensakucnt

For kensakucnt = 2 To 4

For cnt = 2 To 6

If Range("A" & cnt).Value = Range("F" & kensakucnt).Value Then

Range("G" & kensakucnt).Value = Range("A" & cnt).Offset(0, 1).Value

Range("H" & kensakucnt).Value = Range("A" & cnt).Offset(0, 2).Value

End If

End Sub

こちらのコードを修正していくのですが、このコードは検索元と転記先を同一シートで行っていました。

今回は、シート間でデータのやり取りをしたいので、検索元と転記先のシートを明確に分ける必要があります。

具体的には、シート名を以下のようにしています。

転記先のシート名を「カレンダー練習」
検索元のシート名を「イベント一覧」

プロシージャを修正してみよう

２つのシートが用意出来たら、

まず結論ありき、ということで修正後のプロシージャをお見せします。

Sub kensaku_offset1()
    Dim cnt
    Dim kensakucnt
    Dim eSheet As Worksheet '検索元イベント一覧シート
    Dim cSheet As Worksheet '転記先カレンダーシート
    Dim motoLrow
    Dim sakiLrow
    
    Set eSheet = Sheets("イベント一覧") '①
    Set cSheet = Sheets("カレンダー練習") '②
    
    motoLrow = eSheet.Range("A" & Rows.Count).End(xlUp).Row 'イベント一覧シートの最終行'③
    sakiLrow = cSheet.Range("A" & Rows.Count).End(xlUp).Row 'カレンダー練習シートの最終行'④
    
    For kensakucnt = 2 To sakiLrow '⑤
        For cnt = 2 To motoLrow '⑥
            If eSheet.Range("A" & cnt).Value = cSheet.Range("A" & kensakucnt).Value Then '⑦
                cSheet.Range("B" & kensakucnt).Value = eSheet.Range("A" & cnt).Offset(0, 1).Value'⑦
            End If
        Next
    Next
End Sub