エクセルで３年日記を作成したい。

質問

エクセルで添付ファイルのような３年日記を作成しようと奮闘しています。
（365日分コピーして作成は出来ます）
コピーではなく、この３年日記を開けば今日の日付が出てくるようにしたいのですが
何か良い方法があればよろしくお願いいたします。
VBAも自学ですが学び始めたばかりです。プログラムなどがあればお教えいただければチャレンジしたいと思います。
どうかよろしくお願いいたします。

回答No.6

HohoPapa · ベストアンサー

#3の修正版は
起動する都度、起動した日付の欄を
入力済シートの末尾に追記しています。
最大3年分（日数換算：３５６＊３）です。
つまり、単にこの日数分、縦に並びます。

>最終的には昨年、一昨年、本年と3年分の
>その日の記録が見られるようにしたいのです。
>どうかよろしくお願いいたします。　

どのようなレイアウトを期待していることがイメージできません。
このスレッドはいったん閉じ、
まずはしばらく記録し、
その後、イメージを添えて再質問してください。
データさえ揃えば、レイアウトを加工するのは容易と思います。

お礼

丁寧に回答いただき、感謝いたします。一から一歩一歩学習して行きます。
何か楽しさが少し分かったようです。いろいろとありがとうございました。

回答No.5

HohoPapa

単に白紙のシートに3年分を作るだけでよければ、
次のコードでいいと思います。

Sub MakeCalendar()

　'作成開始日を指定
　Const wkDate As Date = #9/1/2019# '#2019/9/1#も可
　Dim RowCnt As Long
　Dim MakeDayCnt As Long

　Application.ScreenUpdating = False

　With ThisWorkbook.Sheets(1)

　　For MakeDayCnt = 0 To 365 * 3

　　　RowCnt = MakeDayCnt * 7 + 1

　　　'日付欄
　　　With .Cells(RowCnt + 1, 2).Resize(1, 3)　'2列目から3列
　　　　.Merge
　　　　.Value = wkDate + MakeDayCnt
　　　　.NumberFormatLocal = "yyyy""年""m""月""d""日(""aaa"")"""
　　　　.HorizontalAlignment = xlCenter
　　　　.VerticalAlignment = xlCenter
　　　End With

　　　With .Cells(RowCnt + 1, 5).Resize(1, 3)　'5列目から3列
　　　　.Merge
　　　　.HorizontalAlignment = xlLeft
　　　　.VerticalAlignment = xlTop
　　　End With

　　　With .Cells(RowCnt + 1, 8).Resize(1, 3)　　'8列目から3列
　　　　.Merge
　　　　.HorizontalAlignment = xlLeft
　　　　.VerticalAlignment = xlTop
　　　End With

　　　'日記欄
　　　With .Cells(RowCnt + 2, 2).Resize(4, 9)　'2列目から4行9列
　　　　.Merge
　　　　.HorizontalAlignment = xlLeft
　　　　.VerticalAlignment = xlTop
　　　End With

　　　'罫線
　　　With .Cells(RowCnt + 1, 2).Resize(5, 9)　'2列目から5行9列
　　　　With .Borders(xlEdgeLeft)
　　　　　.LineStyle = xlContinuous
　　　　End With
　　　　With .Borders(xlEdgeTop)
　　　　　.LineStyle = xlContinuous
　　　　End With
　　　　With .Borders(xlEdgeBottom)
　　　　　.LineStyle = xlContinuous
　　　　End With
　　　　With .Borders(xlEdgeRight)
　　　　　.LineStyle = xlContinuous
　　　　End With
　　　　With .Borders(xlInsideVertical)
　　　　　.LineStyle = xlContinuous
　　　　End With
　　　　With .Borders(xlInsideHorizontal)
　　　　　.LineStyle = xlContinuous
　　　　End With
　　　End With

　　Next MakeDayCnt

　End With

　Application.ScreenUpdating = False

End Sub

お礼

本当にありがとうございます。
厚かましくも最後の質問をさせていただきます。
＃3の修正を使わせていただきます。これは一年経過し、その日の記録を入力しますと、昨年の記録がその画面に出てくるのでしょうか?
最終的には昨年、一昨年、本年と3年分のその日の記録が見られるようにしたいのです。
どうかよろしくお願いいたします。

回答No.4

HohoPapa

#3の修正

空のシートから使用開始することを想定しておらず、
性能が悪く、バグがあるので直しました。　<m(__)m>

Option Explicit

Private Sub Workbook_Open()

　Dim RowCnt As Long
　Dim MaxRow As Long

　With ThisWorkbook.Sheets(1)
　　MaxRow = 365 * 3 * 7
　　RowCnt = 1
　　Do
　　　If RowCnt > MaxRow Then Exit Do
　　　'日付の埋まったセル、かつ結合セルが横に３つ、かつ今日の日付、
　　　If ((IsDate(.Cells(RowCnt, 2).Value) = True) And _
　　　　 (.Cells(RowCnt, 2).MergeArea.Columns.Count = 3) And _
　　　　(.Cells(RowCnt, 2).Value = Date)) Then
　　　　.Cells(RowCnt, 2).Offset(1, 0).Select
　　　　Exit Sub
　　　End If
　　　RowCnt = RowCnt + 1
　　Loop

　　If .Cells(2, 2).Value = "" Then
　　　RowCnt = 1
　　Else
　　　RowCnt = MaxRow
　　　Do
　　　　If RowCnt = 1 Then Exit Do
　　　　If IsDate(.Cells(RowCnt, 2).Value) = True Then
　　　　　Exit Do
　　　　End If
　　　　RowCnt = RowCnt - 1
　　　Loop
　　　RowCnt = RowCnt + 6 '6:使用行数
　　End If

　　'MsgBox (RowCnt)

　　'日付欄
　　With .Cells(RowCnt + 1, 2).Resize(1, 3)　'2列目から3列
　　　.Merge
　　　.Value = Date
　　　.NumberFormatLocal = "yyyy""年""m""月""d""日(""aaa"")"""
　　　.HorizontalAlignment = xlCenter
　　　.VerticalAlignment = xlCenter
　　　.Select
　　End With

　　With .Cells(RowCnt + 1, 5).Resize(1, 3)　'5列目から3列
　　　.Merge
　　　.HorizontalAlignment = xlLeft
　　　.VerticalAlignment = xlTop
　　　.Select
　　End With

　　With .Cells(RowCnt + 1, 8).Resize(1, 3)　　'8列目から3列
　　　.Merge
　　　.HorizontalAlignment = xlLeft
　　　.VerticalAlignment = xlTop
　　　.Select
　　End With

　　'日記欄
　　With .Cells(RowCnt + 2, 2).Resize(4, 9)　'2列目から4行9列
　　　.Merge
　　　.HorizontalAlignment = xlLeft
　　　.VerticalAlignment = xlTop
　　　.Select
　　End With

　　'罫線
　　With .Cells(RowCnt + 1, 2).Resize(5, 9)　'2列目から5行9列
　　　With .Borders(xlEdgeLeft)
　　　　.LineStyle = xlContinuous
　　　End With
　　　With .Borders(xlEdgeTop)
　　　　.LineStyle = xlContinuous
　　　End With
　　　With .Borders(xlEdgeBottom)
　　　　.LineStyle = xlContinuous
　　　End With
　　　With .Borders(xlEdgeRight)
　　　　.LineStyle = xlContinuous
　　　End With
　　　With .Borders(xlInsideVertical)
　　　　.LineStyle = xlContinuous
　　　End With
　　　With .Borders(xlInsideHorizontal)
　　　　.LineStyle = xlContinuous
　　　End With
　　End With
　End With

End Sub

お礼

ありがとうございます。感謝です。これを基にVBAについていろいろ学習して行きたいと思います。
一点質問ですが、実行致しますと一日分の記入が出てきます。これを３年分出てくるようにしたいのですが、複雑になりすぎて無理ですか？　厚かましい質問ですが、叶えられるものならよろしくお願いいたします。

回答No.3

HohoPapa

#2の修正

先ほどのコードは
Ｂ列の日記の内容を書き込む箇所、
（例えば、B10）に日付のみが埋まった場合を考慮していません。
そこで、
本来日記用の日付の埋まるセル（例えば、B2,B9など）は、
横方向に3セルを結合しているようなので
その条件を加味してみました。

更に
＞コピーではなく、
これを見落としていました。

起動直後、
今日の分を入力するための範囲に
日付を埋め、必要なセル結合と罫線を引く作業も
マクロで行うことを期待しているのであれば、
次のようなコードになります。

Option Explicit

Private Sub Workbook_Open()

　Dim RowCnt As Long
　Dim MaxRow As Long
　Dim HitFlg As Boolean

　With ThisWorkbook.Sheets(1)
　　MaxRow = .Columns.Count
　　RowCnt = 1
　　HitFlg = False
　　Do
　　　If RowCnt > MaxRow Then Exit Do
　　　'日付の埋まったセル、かつ結合セルが横に３つ、かつ今日以降の日付、
　　　If ((IsDate(.Cells(RowCnt, 2).Value) = True) And _
　　　　 (.Cells(RowCnt, 2).MergeArea.Columns.Count = 3) And _
　　　　(.Cells(RowCnt, 2).Value >= Date)) Then
　　　　HitFlg = True
　　　　Exit Do
　　　End If
　　　RowCnt = RowCnt + 1
　　Loop
　　If HitFlg = True Then
　　　.Cells(RowCnt, 2).Offset(1, 0).Select
　　Else

　　　RowCnt = MaxRow
　　　Do
　　　　If .Cells(RowCnt, 2).MergeArea.Columns.Count > 1 Then Exit Do
　　　　RowCnt = RowCnt - 1
　　　Loop

　　　With .Cells(RowCnt + 2, 2).Resize(1, 3)
　　　　.Merge
　　　　.Value = Date
　　　　.NumberFormatLocal = "yyyy""年""m""月""d""日(""aaa"")"""
　　　　.HorizontalAlignment = xlCenter
　　　　.VerticalAlignment = xlCenter
　　　　.Select
　　　End With

　　　With .Cells(RowCnt + 2, 5).Resize(1, 3)
　　　　.Merge
　　　　.HorizontalAlignment = xlLeft
　　　　.VerticalAlignment = xlTop
　　　　.Select
　　　End With

　　　With .Cells(RowCnt + 2, 8).Resize(1, 3)
　　　　.Merge
　　　　.HorizontalAlignment = xlLeft
　　　　.VerticalAlignment = xlTop
　　　　.Select
　　　End With

　　　With .Cells(RowCnt + 3, 2).Resize(4, 9)
　　　　.Merge
　　　　.HorizontalAlignment = xlLeft
　　　　.VerticalAlignment = xlTop
　　　　.Select
　　　End With

　　　With .Cells(RowCnt + 2, 2).Resize(5, 9)
　　　　With .Borders(xlEdgeLeft)
　　　　　.LineStyle = xlContinuous
　　　　End With
　　　　With .Borders(xlEdgeTop)
　　　　　.LineStyle = xlContinuous
　　　　End With
　　　　With .Borders(xlEdgeBottom)
　　　　　.LineStyle = xlContinuous
　　　　End With
　　　　With .Borders(xlEdgeRight)
　　　　　.LineStyle = xlContinuous
　　　　End With
　　　　With .Borders(xlInsideVertical)
　　　　　.LineStyle = xlContinuous
　　　　End With
　　　　With .Borders(xlInsideHorizontal)
　　　　　.LineStyle = xlContinuous
　　　　End With
　　　End With

　　End If
　End With

End Sub

補足

ありがとうございます。凄い！！としか申し上げられません。
エクセルを開きご教示いただいプログラムを書きあげました。
これを実行しても変化が起こりません。最後まで申し訳ありません。
実行方法を教えて下さい。

回答No.2

HohoPapa

#1の修正

先ほどのコードは
Ｂ列に日付以外の値が埋まっているときの考慮がされていません。
コードを以下にしてみてください。

Option Explicit

Private Sub Workbook_Open()

　Dim RowCnt As Long
　Dim MaxRow As Long
　Dim HitFlg As Boolean

　With ThisWorkbook.Sheets(1)
　　MaxRow = .Columns.Count
　　RowCnt = 1
　　HitFlg = False
　　Do
　　　If RowCnt > MaxRow Then Exit Do
　　　If ((IsDate(.Cells(RowCnt, 2).Value) = True) And _
　　　　(.Cells(RowCnt, 2).Value >= Date)) Then
　　　　HitFlg = True
　　　　Exit Do
　　　End If
　　　RowCnt = RowCnt + 1
　　Loop
　　If HitFlg = True Then
　　　.Cells(RowCnt, 2).Select
　　Else
　　　MsgBox ("本日以降の行が見つかりません")
　　End If
　End With

End Sub

補足

早速、ご回答いただきありがとうございます。
VBAも始めたばかりです。最初にご教示いただいたプログラムを記入し、ドキドキしながら実行しましたところ、マクロの画面が開き白紙の状態で実行すべきプログラムがありませんでした。
どこかで操作が間違っていると思うのですが・・・。２回目に送付いただいたものを追加して実行してみたいと思います。
何卒もう少しよろしくお願いいたします。（夜になります）

回答No.1

HohoPapa

添付された画像のように
1枚目のシートのＢ列、
この列の何行かごとに日付が埋まっているのであれば、
添付画像を参考に
以下のコードを書くことで期待の動作になるはずです。
よかったら試してみてください。

配置先モジュールは　Thisworkbookです。

Option Explicit

Private Sub Workbook_Open()

　Dim RowCnt As Long
　Dim MaxRow As Long
　Dim HitFlg As Boolean

　With ThisWorkbook.Sheets(1)
　　MaxRow = .Columns.Count
　　RowCnt = 1
　　HitFlg = False
　　Do
　　　If RowCnt > MaxRow Then Exit Do
　　　If .Cells(RowCnt, 2).Value >= Date Then
　　　　HitFlg = True
　　　　Exit Do
　　　End If
　　　RowCnt = RowCnt + 1
　　Loop
　　If HitFlg = True Then
　　　.Cells(RowCnt, 2).Select
　　Else
　　　MsgBox ("本日以降の行が見つかりません")
　　End If
　End With

End Sub