[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『卓上カレンダーの改良』（KonNo）
以下のVBAで卓上カレンダーを作成しています。
1回で4ヶ月分を作成して、その後手動で
A4（縦）1ページに2ヶ月分、2ページで4ヶ月を基本としていますが
一ヶ月が５行の場合は良いのですが、添付画像のように
６行の場合は上手く処理できていません。
コードか改良して６行の場合でも上手く
処理できるようにしたいのでアドバイスをお願いします。
参考用、添付画像
https://imgur.com/Z5G3NDs
Option Explicit
Sub 今月のカレンダー_2()
Dim myDate As String
Dim Nen As Integer, Tuki As Integer
Dim i As Integer, j As Long, k As Integer
Dim ii As Integer, jj As Integer
Dim cn As Long
Dim myTitleD, myTitle(1 To 1, 1 To 7)
Dim myTable(1 To 12, 1 To 7)
Dim c As Range
Dim time As Integer
Dim dist As Integer
Dim T_ad As Variant
Worksheets("sheet2").Activate
Columns("B:H").ColumnWidth = 10
For ii = 1 To 40 Step 13
Rows(ii).RowHeight = 14
Rows(ii + 1).RowHeight = 14
For jj = 1 To 5
Rows(ii + 2 * jj).RowHeight = 16
Rows(ii + 2 * jj + 1).RowHeight = 40
Next
Next
'作成する月を入力
myDate = Application.InputBox(Title:="年月の指定", _
prompt:="年月を2022/2の形式で入力してください", _
Default:="2022/5", Type:=2)
'キャンセルボタンを押したとき、日付でないデータの時は終了する
If myDate = "False" Or Not IsDate(myDate) Then
MsgBox "終了しました"
Exit Sub
End If
Application.ScreenUpdating = False
Range("A:H").Clear
For time = 0 To 3 '4ヶ月分作成
Nen = Year(myDate)
Tuki = Month(myDate) + time
If Tuki > 12 Then
Nen = Nen + 1
Tuki = Tuki - 12
End If
'曜日を配列にセットします
myTitleD = Array("日", "月", "火", "水", "木", "金", "土")
For k = 0 To 6
myTitle(1, k + 1) = myTitleD(k)
Next k
'指定月の日付を配列にセットします
cn = 1
For j = DateSerial(Nen, Tuki, 1) To DateSerial(Nen, Tuki + 1, 0) '末日は 次の月の0日 = 前日の末日
If Day(j) <> 1 And Weekday(j) = 1 Then cn = cn + 2
myTable(cn, Weekday(j)) = Format(j, "m/d")
Next j
'シートに書き出す行を指定
Select Case time
Case 0
dist = 1
Case 1
dist = 14
Case 2
dist = 27
Case 3
dist = 40
End Select
'シートに書き出す
Range("B1").Cells(dist, 1).Value = DateSerial(Nen, Tuki, 1)
Range("B2").Cells(dist, 1).Resize(1, 7).Value = myTitle
Range("B3").Cells(dist, 1).Resize(12, 7).Value = myTable
'書式を設定します
Range("B1").Cells(dist, 1).NumberFormatLocal = "m""月"""
Range("B1").Cells(dist, 1).Font.Size = 8
Range("B1").Cells(dist, 1).HorizontalAlignment = xlCenter
Range("B1").Cells(dist, 1).Font.Bold = True
Range("B2").Cells(dist, 1).Resize(12, 7).HorizontalAlignment = xlCenter
Range("B3").Cells(dist, 1).Resize(11, 1).NumberFormatLocal = "m""月""d""日"""
Range("B1").Cells(dist, 1).Resize(12, 7).Borders.LineStyle = True '罫線
'日曜日は赤色、土曜日は青色にします
Range("B2").Cells(dist, 1).Resize(13, 1).Font.Color = RGB(255, 0, 0) '日曜日：赤色
Range("H2").Cells(dist, 1).Resize(13, 1).Font.Color = RGB(0, 0, 255) '土曜日：青色
'月は、黒色
Range("B1").Font.Color = RGB(0, 0, 0)
Range("B14").Font.Color = RGB(0, 0, 0)
Range("B27").Font.Color = RGB(0, 0, 0)
'祝日（指定休日)のチェックし、紫色の太文字にします
For Each c In Range("B3").Cells(dist, 1).Resize(12, 7)
If Application.CountIf(Worksheets("休日リスト").Range("B4:B24"), c.Value) > 0 Then
c.Font.Color = RGB(112, 48, 160)
c.Font.Bold = True
End If
Next c
'祝日名（指定休日)をチェックして記入
For Each c In Range("B3").Cells(dist, 1).Resize(12, 7)
If Application.CountIf(Worksheets("休日リスト").Range("B4:B24"), c.Value) > 0 Then
c.Offset(1, 0).Value = WorksheetFunction.VLookup(c, Worksheets("休日リスト").Range("B4:D24"), 3)
c.Offset(1, 0).Font.Size = 8
c.Offset(1, 0).HorizontalAlignment = xlCenter
c.Offset(1, 0).VerticalAlignment = xlTop
End If
Next c
Erase myTable
Next time
Application.ScreenUpdating = True
End Sub
＜ 使用 Excel：unknown、使用 OS：unknown ＞
直接の回答ではありません。
参考まで。
Sub test()
Dim tui As Date Dim matu As Date Dim tosi As Integer Dim tuki As Integer tosi = Year(Date) tuki = 1 tui = DateSerial(tosi, tuki, 1) matu = DateSerial(tosi, tuki + 1, 0) MsgBox WorksheetFunction.WeekNum(tui) & vbCrLf & WorksheetFunction.WeekNum(matu) End Sub （OK） 2022/08/01(月) 15:00
参考のマクロは、月が何週まであるかをチェックして対策を立てなさいとのことですか？
つまり月が5週までと6週までの２つのパターンを考えろと。。。。。
（KonNo） 2022/08/01(月) 15:16
>つまり月が5週までと6週までの２つのパターンを考えろと。。。。。
正確にいうと4週、5週、6週の３パターンあります。 最初から６週で決め打ちする方法と必要な週分だけ 作る方法があります。
(末の週-朔日の週)*2+1 が必要な行数になります。
いろんな箇所の調整が必要ですけど。 （OK） 2022/08/01(月) 15:45
「行を必要分増やせば良いだけでは」
そうです。
参照画像を見てもらえれば判ると思いますが
1行目の最初は、日曜日から始まります。
OKさんに指摘された分かったのですが
なので月によって４行、5行、6行の３パターンが存在します。
必要な行数が肝になりそうで
「(末の週-朔日の週)*2+1が必要な行数になります。」
上記をコードに治すのが分かりません。
（KonNo） 2022/08/01(月) 15:56
Option Explicit
Sub MaxWeek()
Dim MaxWeek
Dim InputYearMonth '指定年月
Dim MinDate '指定月の最初の日付
Dim MonthLastDay '指定月の末日の日付け
InputYearMonth = "2022/10"
MinDate = InputYearMonth & "/1"
MonthLastDay = Format(DateAdd("d", -1, DateAdd("m", 1, Format(MinDate, "yyyy/mm/01"))), "d")
MonthLastDay = InputYearMonth & "/" & MonthLastDay
MaxWeek = DateDiff("ww", MinDate, MonthLastDay) + 1
MsgBox MaxWeek
End Sub
（KonNo） 2022/08/01(月) 17:28
Sub sample() Debug.Print CalenderRowNum(#8/1/2022#) Debug.Print CalenderRowNum(#10/1/2022#) Debug.Print CalenderRowNum(#2/1/2026#) End Sub Function CalenderRowNum(d As Date) As Long numday = Day(DateSerial(Year(d), Month(d) + 1, 0)) numblank = Weekday(DateSerial(Year(d), Month(d), 0), vbSaturday) - 1 CalenderRowNum = (numblank + numday) \ 7 + IIf((numblank + numday) Mod 7, 1, 0) End Function （´・ω・`） 2022/08/01(月) 17:53
指定年月が何週まで有るかの関数を頂きました。
自前のコードでとりあえず
以前のコードの改造に着手しました。
形になりそうな時点で一度UPしたいと思います。
（KonNo） 2022/08/01(月) 18:30
ちょっと不安があったので、別案です
Function CalenderRowNum(d As Date) As Long
d1 = DateSerial(Year(d), Month(d), 1)
de = DateSerial(Year(d), Month(d) + 1, 0)
CalenderRowNum = WorksheetFunction.WeekNum(de) - WorksheetFunction.WeekNum(d1) + 1
End Function
（´・ω・`） 2022/08/02(火) 07:03
アドバイスを受けてとりあえず指定年月日のみ1ヶ月分のを作成しようとしていますが
6週まである場合上手く処理できません。
旧コードの使いまわしが原因だと思いますが、コメント（及び修正）をお願いします。
以下現在のサンプルコードです。
Option Explicit
Sub 今月のカレンダー_2()
Dim InputYMD As String '指定年月
Dim Cal_1 As Date, Cal_2 As Date, Cal_3 As Date, Cal_4 As Date
Dim MaxWeek_1 As Long, MaxWeek_2 As Long, MaxWeek_3 As Long, MaxWeek_4 As Long
Dim Nen As Integer, Tuki As Integer
Dim i As Integer, j As Long, k As Integer
Dim ii As Integer, jj As Integer
Dim cn As Long
Dim myTitleD, myTitle(1 To 1, 1 To 7)
Dim myTable(1 To 12, 1 To 7)
Dim c As Range
Dim time As Integer
Dim dist As Integer
Dim T_ad As Variant
Dim i1 As Integer, i2 As Integer, i3 As Integer, i4 As Integer
Dim i5 As Integer, i6 As Integer, i7 As Integer, i8 As Integer
Dim i9 As Integer, i10 As Integer
Worksheets("sheet2").Activate
'作成する年月日を入力
InputYMD = Application.InputBox(Title:="年月日の指定", _
prompt:="年月を2022/2/1の形式で入力してください", _
Default:="2022/5/1", Type:=2)
'キャンセルボタンを押したとき、日付でないデータの時は終了する
If InputYMD = "False" Or Not IsDate(InputYMD) Then
MsgBox "指定年月が不正又は終了がクリックされました。"
Exit Sub
End If
'４ヶ月分の年月日を求める
Cal_1 = DateSerial(Year(InputYMD), Month(InputYMD), 1)
Cal_2 = DateSerial(Year(InputYMD), Month(InputYMD) + 1, 1)
Cal_3 = DateSerial(Year(InputYMD), Month(InputYMD) + 2, 1)
Cal_4 = DateSerial(Year(InputYMD), Month(InputYMD) + 3, 1)
'４ヶ月分の最大週数を求める
MaxWeek_1 = CalenderRowNum(Cal_1)
MaxWeek_2 = CalenderRowNum(Cal_2)
MaxWeek_3 = CalenderRowNum(Cal_3)
MaxWeek_4 = CalenderRowNum(Cal_4)
'カレンダー横幅(日曜〜土曜日まで）
Columns("B:H").ColumnWidth = 10
'---------------
'とりあえず１ヶ月分だけ
'月の行のセルの高さ
For i1 = 1 To 40 Step 13
Rows(i1).RowHeight = 14
Next
'曜日の行の高さ
For i2 = 2 To 41 Step 13
Rows(i2).RowHeight = 14
Next
'月日の行の高さ
For i3 = 3 To 11 Step 2
Rows(i3).RowHeight = 16
Next
'セルの高さ調整（月-日の行）
For i4 = 16 To 24 Step 2
Rows(i4).RowHeight = 16
Next
'セルの高さ調整 （月-日の行）
For i5 = 29 To 37 Step 2
Rows(i5).RowHeight = 16
Next
'セルの高さ調整 （月-日の行）
For i6 = 42 To 50 Step 2
Rows(i6).RowHeight = 16
Next
'セルの高さ調整 - Do it
For i7 = 4 To 12 Step 2
Rows(i7).RowHeight = 40
Next
'セルの高さ調整 - Do it
For i8 = 17 To 25 Step 2
Rows(i8).RowHeight = 40
Next
'セルの高さ調整 - Do it
For i9 = 30 To 38 Step 2
Rows(i9).RowHeight = 40
Next
'セルの高さ調整 - Do it
For i10 = 43 To 51 Step 2
Rows(i10).RowHeight = 40
Next
'セルの高さ調整 - Do it
For i10 = 64 To 72 Step 2
Rows(i10).RowHeight = 40
Next
'セルの高さ調整 - Do it
For i10 = 85 To 93 Step 2
Rows(i10).RowHeight = 40
Next
Nen = Year(InputYMD)
Tuki = Month(InputYMD) + time
If Tuki > 12 Then
Nen = Nen + 1
Tuki = Tuki - 12
End If
'曜日を配列にセットします
myTitleD = Array("日", "月", "火", "水", "木", "金", "土")
For k = 0 To 6
myTitle(1, k + 1) = myTitleD(k)
Next k
'指定月の日付を配列にセットします
cn = 1
For j = DateSerial(Nen, Tuki, 1) To DateSerial(Nen, Tuki + 1, 0) '末日は 次の月の0日 = 前日の末日
If Day(j) <> 1 And Weekday(j) = 1 Then cn = cn + 2
myTable(cn, Weekday(j)) = Format(j, "m/d")
Next j
time = 0
'シートに書き出す行を指定
Select Case time
Case 0
dist = 1
' Case 1
' dist = 14
' Case 2
' dist = 27
' Case 3
' dist = 40
' Case 4
' dist = 53
End Select
'シートに書き出す
Range("B1").Cells(dist, 1).Value = DateSerial(Nen, Tuki, 1)
Range("B2").Cells(dist, 1).Resize(1, 7).Value = myTitle
Range("B3").Cells(dist, 1).Resize(12, 7).Value = myTable
'書式を設定します
Range("B1").Cells(dist, 1).NumberFormatLocal = "m""月"""
Range("B1").Cells(dist, 1).Font.Size = 8
Range("B1").Cells(dist, 1).HorizontalAlignment = xlCenter
Range("B1").Cells(dist, 1).Font.Bold = True
Range("B2").Cells(dist, 1).Resize(12, 7).HorizontalAlignment = xlCenter
Range("B3").Cells(dist, 1).Resize(11, 1).NumberFormatLocal = "m""月""d""日"""
Range("B1").Cells(dist, 1).Resize(12, 7).Borders.LineStyle = True '罫線
'日曜日は赤色、土曜日は青色にします
Range("B2").Cells(dist, 1).Resize(13, 1).Font.Color = RGB(255, 0, 0) '日曜日：赤色
Range("H2").Cells(dist, 1).Resize(13, 1).Font.Color = RGB(0, 0, 255) '土曜日：青色
'月は、黒色
Range("B1").Font.Color = RGB(0, 0, 0)
Range("B14").Font.Color = RGB(0, 0, 0)
Range("B27").Font.Color = RGB(0, 0, 0)
'祝日（指定休日)のチェックし、紫色の太文字にします
For Each c In Range("B3").Cells(dist, 1).Resize(12, 7)
If Application.CountIf(Worksheets("休日リスト").Range("B4:B24"), c.Value) > 0 Then
c.Font.Color = RGB(112, 48, 160)
c.Font.Bold = True
End If
Next c
'祝日名（指定休日)をチェックして記入
For Each c In Range("B3").Cells(dist, 1).Resize(12, 7)
If Application.CountIf(Worksheets("休日リスト").Range("B4:B24"), c.Value) > 0 Then
c.Offset(1, 0).Value = WorksheetFunction.VLookup(c, Worksheets("休日リスト").Range("B4:D24"), 3)
c.Offset(1, 0).Font.Size = 8
c.Offset(1, 0).HorizontalAlignment = xlCenter
c.Offset(1, 0).VerticalAlignment = xlTop
End If
Next c
Erase myTable
Application.ScreenUpdating = True
End Sub
Function CalenderRowNum(d As Date) As Long
Dim d1 As Date, de As Date
d1 = DateSerial(Year(d), Month(d), 1)
de = DateSerial(Year(d), Month(d) + 1, 0)
CalenderRowNum = WorksheetFunction.WeekNum(de) - WorksheetFunction.WeekNum(d1) + 1
End Function
（KonNo） 2022/08/02(火) 09:15
済みませんが、目指す完成型がわからないのでアドバイスできません
>6週まである場合上手く処理できません 具体的に書いてください。 すべての場合で、６週までの書式にしておけばいいのでは？ （´・ω・`） 2022/08/02(火) 09:32
できるだけ元のコードを活かす形で修正してみました。 参考になりますか？
Sub test()
Dim myDate As String
Dim nen As Long, tuki As Long
Dim i As Long, j As Long, k As Long
Dim m As Long
Dim cn As Long
Dim dayOfWeek
Dim myTitle(1 To 1, 1 To 7)
Dim myTable(1 To 12, 1 To 7)
Dim c As Range
Dim pos As Long
Dim n_body As Long
Dim n_line As Long
Worksheets("sheet2").Activate
Columns("B:H").ColumnWidth = 10
dayOfWeek = Array("日", "月", "火", "水", "木", "金", "土")
'作成する月を入力
myDate = Application.InputBox(Title:="年月の指定", _
prompt:="年月を2022/2の形式で入力してください", _
Default:="2022/5", Type:=2)
Application.ScreenUpdating = False
Range("A:H").Clear
pos = 1 '各月の基準となる開始行
For m = 0 To 3 '4ヶ月分作成
nen = Year(myDate)
tuki = Month(myDate) + m
If tuki > 12 Then
nen = nen + 1
tuki = tuki - 12
End If
'曜日を配列にセット
For k = 0 To 6
myTitle(1, k + 1) = dayOfWeek(k)
Next
'指定月の日付を配列myTableにセット
cn = 1
For j = DateSerial(nen, tuki, 1) To DateSerial(nen, tuki + 1, 0)
If Day(j) <> 1 And Weekday(j) = 1 Then cn = cn + 2
myTable(cn, Weekday(j)) = Format(j, "m/d")
Next
n_body = cn + 1 '本体部分(2行ワンセットの8,10,12行）の行数
n_line = n_body / 2 '表示する週の数（4,5,6週のいずれか）
'行高の調整
Range("B1").Cells(pos, 1).Resize(2, 1).EntireRow.RowHeight = 14
For k = 1 To n_line
Range("B1").Cells(pos + 2 * k, 1).EntireRow.RowHeight = 16 '日付欄
Range("B1").Cells(pos + 2 * k + 1, 1).EntireRow.RowHeight = 40 '内容欄
Next
Range("B1").Cells(pos, 1).Value = DateSerial(nen, tuki, 1) '月初
Range("B2").Cells(pos, 1).Resize(1, 7).Value = myTitle '曜日名
Range("B3").Cells(pos, 1).Resize(n_body, 7).Value = myTable '日データ
'書式を設定
Range("B1").Cells(pos, 1).NumberFormatLocal = "m""月"""
Range("B1").Cells(pos, 1).Font.Size = 8
Range("B1").Cells(pos, 1).HorizontalAlignment = xlCenter
Range("B1").Cells(pos, 1).Font.Bold = True
Range("B2").Cells(pos, 1).Resize(n_body, 7).HorizontalAlignment = xlCenter
Range("B3").Cells(pos, 1).Resize(n_body - 1, 1).NumberFormatLocal = "m""月""d""日"""
Range("B1").Cells(pos, 1).Resize(n_body + 2, 7).Borders.LineStyle = True '罫線
'日曜日は赤色、土曜日は青色
Range("B2").Cells(pos, 1).Resize(n_body + 1, 1).Font.Color = vbRed '日曜日：赤色
Range("H2").Cells(pos, 1).Resize(n_body + 1, 1).Font.Color = vbBlue '土曜日：青色
'月は、黒色
Range("B1").Cells(pos, 1).Font.Color = vbBlack 'RGB(0, 0, 0)
'祝日（指定休日)のチェックし、紫色の太文字にします
For Each c In Range("B3").Cells(pos, 1).Resize(n_body, 7)
If Application.CountIf(Worksheets("休日リスト").Range("B4:B24"), c.Value) > 0 Then
c.Font.Color = RGB(112, 48, 160)
c.Font.Bold = True
End If
Next c
'祝日名（指定休日)をチェックして記入
For Each c In Range("B3").Cells(pos, 1).Resize(n_body, 7)
If Application.CountIf(Worksheets("休日リスト").Range("B4:B24"), c.Value) > 0 Then
c.Offset(1, 0).Value = WorksheetFunction.VLookup(c, Worksheets("休日リスト").Range("B4:D24"), 3)
c.Offset(1, 0).Font.Size = 8
c.Offset(1, 0).HorizontalAlignment = xlCenter
c.Offset(1, 0).VerticalAlignment = xlTop
End If
Next c
pos = pos + 2 + n_body + 1 '次の月の書き込み開始位置を計算(1はfiller)
Erase myTable
Next
Application.ScreenUpdating = True
End Sub
元のコードでも、変数cnに、各月の行数の差異が反映されているから、 これを使えばよい、ということなんでしょう。
# Range("B1").Cells(pos, 1)という指定の仕方は余り意味がないように思います。
# Cells(pos, 2)で良い訳ですし、アドホック感が否めません。
# また、いくつかのサブに分けたほうがコードの構造も分かりやすくなるかもしれません。
# 最初から書き直すと良いと考える人もいるかと思いますね。
と、ここまで作ってふと思ったが、印刷のことを考えると、 どの月も6週ある前提で固定の行数にあてはめたほうがよかったかも？ まあ、各月の間には一行だけ余白行を入れて、 ふたつの月が終了したところに印刷改ページを入れればよいのかなあ。
（γ） 2022/08/02(火) 10:04
´・ω・`さん興味を持っていただきありがとうございます。
完成形のイメージがわからないと言うことなので
完成形は、
質問の最初に添付した画像を参照下さい。
9月分はきれいに作画されていますが
10月分は第６週の作画が不完全です。
（罫線が引かれていない状況）
これで卓上カレンダーのイメージが出来るでしょうか ？
＞すべての場合で、６週までの書式にしておけばいいのでは？
OKさんが指摘されたように
月によって4,5,6週(4行、5行、6行）の３パターンが存在します。
６週で固定すれば、4，5週の場合
不用な空白を含む罫線が作画されてしまうと思われます。
'-----------------------
γさん、コードの提示ありがとうございます。
コードを追いかけるのに少し時間を下さい。
＞どの月も6週ある前提で固定の行数にあてはめたほうがよかったかも？
6週で固定すれば、4，5週の場合
不用な空白を含む罫線が作画されてしまいませんか ？
（KonNo） 2022/08/02(火) 10:12
というか私のエクセル2019には、
「どの年度にも対応する月単位のカレンダー」
というのがテンプレートに入っていますが、
それを使えば比較的容易に希望するカレンダーが作れそうな気がします。
様式もほぼ同じですし。
それを直せば、マクロ無しで期待した雛形が作れそうな気がします。
数式が残るのが嫌なら、マクロ付きテンプレートにして、新しく保存するときに
数式を値に変えるマクロだけ作るというアプローチもあるかと思います。
もちろん新たに保存するときまマクロ無し保存にします。
一案として。。。。
（まっつわん） 2022/08/02(火) 10:36
>質問の最初に添付した画像を参照下さい。 いや、だから．．．
>6週で固定すれば、4，5週の場合 >不用な空白を含む罫線が作画されてしまいませんか ？ それを気にしないというのも一つの答えなんですよ。
６週分固定にして、各月の最初の行位置を固定するとコード書くのが楽になります けど、余計な空白が生じるので見た目がよくない？？ （とは私は思いませんが） 各月の週数に応じて次ぎの月の初めの行を可変にすると 余計な空白行は生じませんがコードはそれだけ複雑になります。
どっちとるの？という話です。
空白行（６週目の行）を非表示にするという解決策もあります。 そうすると改ページ位置は動かさなくていいのでこれが一番楽かもしれません （´・ω・`） 2022/08/02(火) 10:45
あ、罫線の描画だけ可変にするというのもありです 印刷したとき、全ページで各月の位置がずれないというのは、 日本人的には書式としての受けがいいかもしれません （´・ω・`） 2022/08/02(火) 10:46
私のPC（excel2021)をチェックしましたが
「どの年度にも対応する月単位のカレンダー」
というのがテンプレートは見つかりませんでした。
「Officeのカスタムテンプレート」フォルダーにもありませんでした。
テンプレートの拡張子である「xltx」で検索しましたが
それらしきファイルを見つけられませんでした。
6週固定で不用な空白が表示されても気にしないと言う案は
正直私は気になるので6週固定で無いマクロはを作成したいと思います。
’----------------------------------
´・ω・`さん、
6週固定で不用な空白が表示されても気にしないと言う案は
正直私は気になるので6週固定で無いマクロを作成したいと思います。
＞空白行（６週目の行）を非表示にするという解決策もあります。
＞ そうすると改ページ位置は動かさなくていいのでこれが一番楽かもしれません
６週分固定でコードを作成したほうがコードが複雑にならずに簡単にるのは判るような気がします。
但しその場合、空白の６週目の行が必要ないとの判断するコードや
非表示にコードを追加しなくては行けないので逆に複雑にならないのでしょうか ？ （私の今のスキルではできそうにありません。）
初心者の私には、後でコードを見直したときに分かりやすいコードを目指したいと思います。
’-----------------------------------
γさん、
コードを走らせてみて6週有る有る場合でも処理できました。
（４週しか無い場合の年月が不明なのでそこはチェックできていません。）
改めてお礼申し上げます。
（KonNo） 2022/08/02(火) 11:22
近いところでは、2015年2月 もしくは 2026年2月です
（わからん） 2022/08/02(火) 11:31
もちろん4週しかないときのもの(2015も念のためチェックしましたよ。
For k = 2010 To 2023
d = DateSerial(k, 2, 1)
Debug.Print d; Application.Weekday(d)
Next
とかすれば何年が2月で日曜始まりかわかりますからね。
6週と5週の差異は、行高で調整してもいいかもしれません。 まあ用途は自己用でしょうし、たぶん学習用素材だから、 それほど神経使うものでもないとは思います。 （γ） 2022/08/02(火) 11:39
’-------------------
γさん、４週しか無い場合もチェックしてのコードだったのですね。
ご助力に頭が下がります。
卓上カレンダーは、自己用なのでおっしゃるように神経を使うものでは無く
少しDo_itを書き出せれば良いので多くは望んでいません。
ところで、先に提案の有った以下の件ですが、
＞各月の間には一行だけ余白行を入れて、
＞ふたつの月が終了したところに印刷改ページを入れればよいのかなあ。
つまり、ｍ＝１の場合に
現在の行に改ページを入れる事になると思うのですが
具体的にはどのようなコードになるのでしょうか ？
（KonNo） 2022/08/02(火) 11:57
（隠居Z） 2022/08/02(火) 12:05
１月ごとに表示、印刷では
A4（縦）１ページ印刷では、下半分が利用されずに無駄となりコスパが悪くなります。
A4(縦)で2ヶ月分の現在のサイズが、印刷で丁度良い卓上サイズなのです。
（KonNo） 2022/08/02(火) 12:17
（隠居Z） 2022/08/02(火) 12:41
Sub Sample(ByVal Cal As Date, Months As Long)
Dim FirstRange As Range
Dim InputRange As Range
Dim InputDate As Date
Dim oRow As Long, oCol As Long
Dim i As Long
'書き出しセルの設定
Set FirstRange = Range("B1")
'月、曜日を入力
Call Gessho(FirstRange, Cal)
'朔日の曜日情報で書き出し位置を更新
Set InputRange = FirstRange.Offset(2, Weekday(Cal) - 1)
'朔日の日付入力
InputRange.Value = Cal
'最終日までループ
For i = 1 To WorksheetFunction.EDate(Cal, Months) - Cal - 1
'入力日付設定
InputDate = Cal + i
'日曜日の場合は2段下げて6列左
If Weekday(InputDate) = 1 Then
oRow = 2
oCol = -6
'日曜日以外は段下げ無し1列右
Else
oRow = 0
oCol = 1
End If
'前の日と月が異なる場合は4段下げて月と曜日の行を追加
If Month(InputDate) <> Month(InputDate - 1) Then
Call Gessho(Cells(InputRange.Row + 2, "B"), InputDate)
oRow = 4
End If
'行と列の設定を反映
Set InputRange = InputRange.Offset(oRow, oCol)
'日付を入力
InputRange.Value = InputDate
Next
End Sub
下手の横好きですが一日ずつ日付を書き足していくマクロを書いてみました。
（下手の横好き） 2022/08/02(火) 12:47
Sub Gessho(Rng As Range, buf As Date)
With Rng
'シートに書き出す
.Value = buf
.Offset(1).Resize(, 7).Value = Array("日", "月", "火", "水", "木", "金", "土")
'書式を設定します
.NumberFormatLocal = "m""月"""
.Font.Size = 8
.HorizontalAlignment = xlCenter
.Font.Bold = True
End With
End Sub
おっとと 不足がありました。
（下手の横好き） 2022/08/02(火) 12:50
アクティブ セルの上に水平な改ページを追加すればと思い以下のように
２箇所コード（改ページの削除 と 挿入）を追加しましたがうまく処理できていないようです。
Dim n_line As Long
Worksheets("sheet2").Activate
'改ページを全て解除
Worksheets("sheet2").ResetAllPageBreaks
（途中 省略）
pos = pos + 2 + n_body + 1 '次の月の書き込み開始位置を計算(1はfiller) Erase myTable
If m = 1 Then
Worksheets("sheet2").HPageBreaks.Add Before:=ActiveCell
End If
（KonNo） 2022/08/02(火) 12:54
＞ついでに、二か月目と、
＞最後に印刷かけちゃうとか。。。ｗ＾＾；
同じ印刷するなら印刷を２回行うより１回で済ませればその方が良くないですか ？
その為、現在改ページを挿入できるようにコードを改良中です。
（KonNo） 2022/08/02(火) 12:59
長げー、長げーわ！ どーでもえーことをダラダラダラダラ。 ほぼ出来たんなら、後は自分で好きなよーにせーよ。書いたコードのＵＰも不要！ もー飽きた。
（NonNo） 2022/08/02(火) 13:06
定番の標準モジュールに提示頂いたコードをコピペしました。
提示いただいたコードは、マクロの開始から呼び出す形式では無いのですね。
（マクロの開始にノミネートされない）
又以下のようにしてVBAの実行から呼び出すのかとも思ったのですが
違っていました。
Sub Sample("2022/10/1",4)
私のスキルが低くてどのようにこのコードを利用して良いのかが分かりません。
すいませんが、アドバイスをお願いします。
（KonNo） 2022/08/02(火) 13:18
Option Explicit
Public Sub Test()
Const Months = 4 '出力月数
'以前のカレンダーを削除
Worksheets("sheet2").UsedRange.EntireRow.Delete
Dim FirstDay As Date, res
res = Application.InputBox(Title:="年月の指定", _
prompt:="年月を2022/2の形式で入力してください", _
Default:="2022/5", Type:=2)
If IsDate(res) Then
FirstDay = CDate(res)
Else
MsgBox "年月を入力してください。"
Exit Sub
End If
Application.ScreenUpdating = False
Dim OutputCell As Range
Set OutputCell = Worksheets("Sheet2").Cells(1, 1)
Dim i As Long
For i = 1 To 4
Set OutputCell = MakeMonthCalendar(FirstDay, OutputCell).Offset(2)
Worksheets("sheet2").HPageBreaks.Add Before:=OutputCell
FirstDay = DateAdd("m", 1, FirstDay)
Next
Application.ScreenUpdating = True
End Sub
Public Function MakeMonthCalendar(FirstDay As Date, OutputCell As Range) As Range
Dim aryCalendar(1 To 14, 1 To 7)
aryCalendar(1, 1) = Format(FirstDay, "yyyy年mm月") '年月
Dim i As Long
For i = 1 To 7 '曜日タイトル
aryCalendar(2, i) = WeekdayName(i, True)
Next
Dim LastDay As Date, r As Long
LastDay = DateSerial(Year(FirstDay), Month(FirstDay) + 1, 0)
r = 3
Dim d As Date, idx As Long
For d = FirstDay To LastDay
aryCalendar(r, Weekday(d)) = d
idx = 0
On Error Resume Next
idx = WorksheetFunction.Match(CLng(d), Worksheets("休日リスト").Range("B4:B24"), 0)
On Error GoTo 0
If idx > 0 Then aryCalendar(r + 1, Weekday(d)) = Worksheets("休日リスト").Range("B4:D24").Cells(idx, 3)
If Weekday(d) = vbSaturday Then r = r + 2
Next
If Weekday(LastDay) = vbSaturday Then r = r - 2
Dim outputRng As Range
Set outputRng = OutputCell.Resize(r + 1, 7)
outputRng.Value = aryCalendar
SetCalendarFormat outputRng
Set MakeMonthCalendar = outputRng.Cells(r + 1, 1) 'カレンダーの最終セル
End Function
Public Sub SetCalendarFormat(CalendarRng As Range)
Const rHeight1 = 14
Const rHeight2 = 16
Const rHeight3 = 40
With CalendarRng
.HorizontalAlignment = xlCenter
.Columns(1).Font.Color = vbRed '日曜日：赤色
.Columns(7).Font.Color = vbBlue '土曜日：青色
.Rows(1).Font.Color = vbBlack '年月：黒色
'行高,書式設定
Dim i As Long
For i = 1 To .Rows.Count
If i <= 2 Then
.Rows(i).RowHeight = rHeight1
ElseIf i Mod 2 = 1 Then
.Rows(i).RowHeight = rHeight2
.Rows(i).NumberFormatLocal = "m""月""d""日"""
Else
.Rows(i).RowHeight = rHeight3
On Error Resume Next
With .Rows(i).SpecialCells(xlCellTypeConstants)
.Font.Size = 8
.VerticalAlignment = xlTop
.Offset(-1).Font.Color = RGB(112, 48, 160)
.Offset(-1).Font.Bold = True
End With
On Error GoTo 0
End If
Next
End With
End Sub
１か月分のカレンダーを出力する関数(MakeMonthCalendar) そのカレンダーの書式を設定する関数(SetCalendarFormat) に分割してみました。
４か月分出力したければ、MakeMonthCalendar を４回繰り返します。 半年分とか１年分出力したいということは、繰り返し数を変更するだけですみます。
書式を変更したいというときも、SetCalendarFormatを変更すればいいだけ、 というように変更しやすくなると思います。
あくまで自分がつくるならというものですので、時間があれば研究用としてご利用ください。
（hatena） 2022/08/02(火) 13:25
↑では６週固定ですね。
セル範囲を６週固定で、あとは見せ方だけだと思うんですが。。。。ということを言いたかった。
（まっつわん） 2022/08/02(火) 13:50
コードを走らせてみましたが、EXCELが異常終了します。
Windowsエラー報告を外部に発信しようとします。
もう一度、Excelを起動させると「ドキュメントの回復」を促す表示が出ます。
ステップ実行でエラー場所を特定していくと
以下の処理中で発生しているようです。
Public Sub SetCalendarFormat(CalendarRng As Range)
途中まで処理されているようで
添付画像のところで終わっていました。
https://imgur.com/ifhmaKh
（KonNo） 2022/08/02(火) 14:02
＞セル範囲を６週固定で、あとは見せ方だけだと思うんですが。。。。ということを言いたかった。
おっしゃりたいことは、十分理解しています。
６行固定で空白が出力される問題は、個人の好き嫌いです。
（KonNo） 2022/08/02(火) 14:08
修正済みのコードは、改行も挿入してますので、下記のコードがなければ、
修正前のコードです。
Worksheets("sheet2").HPageBreaks.Add Before:=OutputCell
（hatena） 2022/08/02(火) 14:15
Option Explicit
Public Sub Test()
Const Months = 4 '出力月数
'以前のカレンダーを削除
Worksheets("sheet2").UsedRange.EntireRow.Delete
Worksheets("sheet2").ResetAllPageBreaks
Dim FirstDay As Date, res
res = Application.InputBox(Title:="年月の指定", _
prompt:="年月を2022/2の形式で入力してください", _
Default:="2022/5", Type:=2)
If IsDate(res) Then
FirstDay = CDate(res)
Else
MsgBox "年月を入力してください。"
Exit Sub
End If
Application.ScreenUpdating = False
Dim OutputCell As Range
Set OutputCell = Worksheets("Sheet2").Cells(1, 1)
Dim i As Long
For i = 1 To 4
Set OutputCell = MakeMonthCalendar(FirstDay, OutputCell).Offset(2)
Worksheets("sheet2").HPageBreaks.Add Before:=OutputCell
FirstDay = DateAdd("m", 1, FirstDay)
Next
Application.ScreenUpdating = True
End Sub
Public Function MakeMonthCalendar(FirstDay As Date, OutputCell As Range) As Range
Dim aryCalendar(1 To 14, 1 To 7)
aryCalendar(1, 1) = Format(FirstDay, "yyyy年mm月") '年月
Dim i As Long
For i = 1 To 7 '曜日タイトル
aryCalendar(2, i) = WeekdayName(i, True)
Next
Dim LastDay As Date, r As Long
LastDay = DateSerial(Year(FirstDay), Month(FirstDay) + 1, 0)
r = 3
Dim d As Date, idx As Long
For d = FirstDay To LastDay
aryCalendar(r, Weekday(d)) = d
idx = 0
On Error Resume Next
idx = WorksheetFunction.Match(CLng(d), Worksheets("休日リスト").Range("B4:B24"), 0)
On Error GoTo 0
If idx > 0 Then aryCalendar(r + 1, Weekday(d)) = Worksheets("休日リスト").Range("B4:D24").Cells(idx, 3)
If Weekday(d) = vbSaturday Then r = r + 2
Next
If Weekday(LastDay) = vbSaturday Then r = r - 2
Dim outputRng As Range
Set outputRng = OutputCell.Resize(r + 1, 7)
outputRng.Value = aryCalendar
SetCalendarFormat outputRng
Set MakeMonthCalendar = outputRng.Cells(r + 1, 1) 'カレンダーの最終セル
End Function
Public Sub SetCalendarFormat(CalendarRng As Range)
Const rHeight1 = 14
Const rHeight2 = 16
Const rHeight3 = 40
With CalendarRng
.Borders.LineStyle = True
.HorizontalAlignment = xlCenter
.Columns(1).Font.Color = vbRed '日曜日：赤色
.Columns(7).Font.Color = vbBlue '土曜日：青色
.Rows(1).Font.Color = vbBlack '年月：黒色
'行高,書式設定
Dim i As Long
For i = 1 To .Rows.Count
If i <= 2 Then
.Rows(i).RowHeight = rHeight1
ElseIf i Mod 2 = 1 Then
.Rows(i).RowHeight = rHeight2
.Rows(i).NumberFormatLocal = "m""月""d""日"""
Else
.Rows(i).RowHeight = rHeight3
On Error Resume Next
With .Rows(i).SpecialCells(xlCellTypeConstants)
.Font.Size = 8
.VerticalAlignment = xlTop
.Offset(-1).Font.Color = RGB(112, 48, 160)
.Offset(-1).Font.Bold = True
End With
On Error GoTo 0
End If
Next
End With
End Sub
（hatena） 2022/08/02(火) 14:21
さらに少し修正されたコードに入れ替えて
コードを走らせてみましたが、同じくEXCELが異常終了します。
前回と同じで
ステップ実行でエラー場所を特定していくと
同じく以下の処理中で発生しているようです。
Public Sub SetCalendarFormat(CalendarRng As Range)
瞬間的に異常終了するので場所が特定できていないかも知れませんが
コード的には、以下の部分付近と思われます。
With .Rows(i).SpecialCells(xlCellTypeConstants)
.Font.Size = 8
.VerticalAlignment = xlTop
今回も途中まで処理されているようで
今回の処理も以前の添付画像とほぼ同じように表示されています。
（KonNo） 2022/08/02(火) 14:46
当方のサンプルでは問題なく動いているので不思議ですね。
PCを再起動させてから、 下記の部分をコメントアウトして実行するとどうでしょうか。
On Error Resume Next
With .Rows(i).SpecialCells(xlCellTypeConstants)
.Font.Size = 8
.VerticalAlignment = xlTop
.Offset(-1).Font.Color = RGB(112, 48, 160)
.Offset(-1).Font.Bold = True
End With
On Error GoTo 0
（hatena） 2022/08/02(火) 14:55
それでは私はこのあたりで、書式は最低限です。 フォントや色はやってません
Sub test()
Dim d0 As Date
strdatetext = InputBox("年月を2022/2の形式で入力してくださいを", "日付", Format(DateSerial(Year(Date), Month(Date) + 1, 1), "yyyy/mm/dd"))
If IsDate(strdatetext) Then
d0 = DateValue(strdatetext)
Else
Exit Sub
End If
Cells.Delete
For i = 0 To 3
MakeCalender Cells(i * 16 + 1, 2), DateSerial(Year(d0), Month(d0) + i, 1)
Next
End Sub
Function MakeCalender(topleftCell As Range, ByVal d As Date)
Dim d1 As Date, de As Date
d1 = DateSerial(Year(d), Month(d), 1)
de = DateSerial(Year(d), Month(d) + 1, 0)
numWeek = WorksheetFunction.WeekNum(de) - WorksheetFunction.WeekNum(d1) + 1
numblank = Weekday(d1, vbSunday) - 1
With topleftCell.Resize(, 7)
.Cells(1, 1).Value = Format(d, "M月")
.Rows(2).Value = Array("日", "月", "火", "水", "木", "金", "土")
Do While d1 <= de
.Cells(((numblank + Day(d1) - 1) \ 7) * 2 + 3, Weekday(d1, vbSunday)).Value = d1
d1 = d1 + 1
Loop
With .Resize(numWeek * 2 + 2)
.ColumnWidth = 10
.HorizontalAlignment = xlCenter
.RowHeight = 13
For i = 3 To .Rows.Count Step 2
.NumberFormatLocal = "m月d日"
Next
For i = 4 To .Rows.Count Step 2
.Rows(i).RowHeight = 40
Next
.BorderAround xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
End With
Set MakeCalender = .Cells
End With
End Function
（´・ω・`） 2022/08/02(火) 14:58
PCを再起動してアドバイスにあった部分をコメントアウトして実行すると
エラー無く処理されました。
’------------------
´・ω・`さん、参考コードありがとうございます。
コードを走らせてエラー無く処理出来るのを確認できました。
まだゆっくり見直す時間が取れていませんが後でチェックしたいと思います。
´・ω・`さんは、退席されるとの事、お付き合い願いありがとうございました。
改めてお礼申し上げます。
（KonNo） 2022/08/02(火) 15:31
Sub test()
Dim rngBody As Range
Dim lngStart As Long, lngEnd As Long
Dim ixRow As Long
Dim ixCol As Long
Dim d As Long
'シートの初期化
ActiveSheet.UsedRange.Offset(2).EntireRow.Delete
Range("B2").Formula = "=MONTH(B6)&""月"""
'開始日付の入力
InputDate:
If GetMydate(lngStart, lngEnd) = False Then Exit Sub
If lngStart < 1 Then
MsgBox "不正な日付です。"
GoTo InputDate
End If
'書き出し位置初期値
ixCol = Weekday(lngStart)
ixRow = 4
'日数分繰り返し
For d = lngStart To lngEnd
Cells(ixRow, ixCol + 1).Value = CDate(d)
'次の書き込み位置
ixCol = ixCol + 1
If ixCol > 7 Then
ixCol = 1
ixRow = ixRow + 2
End If
'月が変わったら行を変える
If Month(d) <> Month(d + 1) Then
ixRow = ixRow + 2
End If
Next
End Sub
Private Function GetMydate(ByRef s As Long, ByRef e As Long) As Boolean
Dim d As Variant
d = Application.InputBox(Title:="年月の指定", _
prompt:="年月を2022/2の形式で入力してください", _
Default:="2022/5", Type:=2)
If d = False Then Exit Function
If InStr(1, d, "/") < 5 Then d = "0"
On Error GoTo ErrH
s = CDate(d)
On Error GoTo 0
If s > 0 Then
e = DateAdd("m", 4, s) - 1
End If
GetMydate = True
Exit Function
ErrH:
s = 0
Resume Next
End Function
シンプルに日付だけ。。。
決まった様式にはめ込む方が楽だけども。。。。
※日付の関数はてきとうな感じです＾＾；
（まっつわん） 2022/08/02(火) 15:59
Worksheets("sheet2").Activate
'改ページを全て解除
Worksheets("Sheet2").ResetAllPageBreaks
(途中、省略）
pos = pos + 2 + n_body + 1 '次の月の書き込み開始位置を計算(1はfiller)
Erase myTable
'ページ改行を挿入
If m = 1 Then
Worksheets("Sheet2").Cells(pos, 1).PageBreak = xlPageBreakManual
End If
（KonNo） 2022/08/02(火) 17:00
もう一回言う。
自分で好きなようにやれ！ 人を巻き込むな！！
アホちゃうかこいつ。
（NonNo） 2022/08/02(火) 17:39
そういう前提で長い目で相手してあげましょう
相手をしたく無いのであればスルーすればよいです
文句をつける必要はないでしょう
（とおりすがり） 2022/08/02(火) 17:56
＞試しもしないで何を言うか。
もちろん試しています。
エラー無く処理されているので
個人的には、そのコードで良さそうですがコメントを求めているのです。
（KonNo） 2022/08/02(火) 18:26
既に、様々なご案内があったようで、今更ですが、
私ならこんな感じで！みたいなのを作ってみました、ご考察の砌、
何かの足しにでもなれば、幸甚です。ならなければゴミ箱ポイお願いいたします。
駄作なので、ならないかも。。。＾＾；
Option Explicit
Sub 今月のカレンダー_IZ001()
Dim myDate&, w(), i&, rr As Range
Worksheets("Sheet2").Activate
ActiveWindow.View = xlNormalView
getmydate myDate
For i = 0 To 3
arymk myDate, w, i
wswrite i, w, rr
arrange rr
Next
myprintsetup
Erase w
End Sub
Private Sub myprintsetup()
Dim a$, mr&
With Worksheets("SHeet2")
a = Intersect(.Range("B:H"), .UsedRange).Address
mr = .Range("FDX1")
.UsedRange.RowHeight = 16
.UsedRange.ColumnWidth = 12
.ResetAllPageBreaks
With .PageSetup
.PrintArea = a
.Zoom = False
.CenterHorizontally = True
.CenterVertically = True
.FitToPagesWide = 1
.FitToPagesTall = False
'余白
.TopMargin = Application.CentimetersToPoints(1)
.BottomMargin = Application.CentimetersToPoints(1)
.LeftMargin = Application.CentimetersToPoints(3)
.RightMargin = Application.CentimetersToPoints(2.5)
.HeaderMargin = Application.CentimetersToPoints(1.3)
.FooterMargin = Application.CentimetersToPoints(1.3)
End With
.HPageBreaks.Add Range("A" & mr)
.Range("FDX1").Value = Empty
End With
End Sub
Private Sub arymk(myDate&, w(), ByVal i&)
Dim v(6), idx(), n&, j&, k&, f&, t&, a&, x, xx&, nen, tuki
ReDim Preserve idx(n)
nen = Year(DateAdd("m", i, myDate))
tuki = Month(DateAdd("m", i, myDate))
idx(n) = Array(nen & "年", Format(tuki, "00") & "月", "", "", "", "", "")
n = n + 1
ReDim Preserve idx(n)
idx(n) = Array("日", "月", "火", "水", "木", "金", "土")
n = n + 1
f = DateSerial(nen, tuki, 1)
t = DateSerial(nen, tuki + 1, 0)
For j = f To t
x = Application.Match(Format(j, "aaa"), idx(1), 0) - 1
If Not IsError(x) Then
v(x) = j
If Format(j, "aaa") = "土" And j < t Then
xx = Day(j)
ReDim Preserve idx(n)
idx(n) = v
Erase v
For a = 1 To 4
n = n + 1
ReDim Preserve idx(n)
idx(n) = v
Next
End If
End If
Next
ReDim Preserve idx(n)
idx(n) = v
Erase v
For a = 1 To 3
n = n + 1
ReDim Preserve idx(n)
idx(n) = v
Next
ReDim w(1 To UBound(idx) + 1, 1 To 7)
For k = LBound(idx) To UBound(idx)
For j = 0 To UBound(idx(k))
w(k + 1, j + 1) = idx(k)(j)
Next
Next
Erase idx, v
End Sub
Private Sub wswrite(i&, idx(), rr As Range)
Dim lR As Long
With Worksheets("Sheet2")
If i = 0 Then
.Cells.Delete
lR = .Cells(.Rows.Count, 2).End(xlUp).Row + 1
lR = IIf(.Cells(1, 2) = "", 1, lR)
Else
lR = .Cells(.Rows.Count, 2).End(xlUp).Row + 1 + 4
End If
.Cells(lR, 2).Resize(UBound(idx), 7) = idx
Set rr = .Cells(lR, 2).Resize(UBound(idx), 7)
If i = 2 Then
.Cells(1, "FDX").Value = lR
End If
End With
End Sub
Private Sub arrange(ByVal rr As Range)
Dim i&, j&
For i = 3 To rr.Rows.Count Step 4
For j = 1 To rr.Columns.Count
If rr(i, j) <> "" Then
rr(i, j).NumberFormatLocal = "yyyy/mm/dd"
Select Case j
Case 1
rr(i, j).Font.Color = vbRed
Case 7
rr(i, j).Font.Color = vbBlue
End Select
End If
rr(i, j).Offset(1).Resize(3).Merge
Next
Next
rr.Borders.LineStyle = xlContinuous
End Sub
Private Sub getmydate(myDate&)
'作成する月を入力
Dim x As String
x = Application.InputBox(Title:="年月の指定", _
prompt:="年月を2022/2の形式で入力してください", _
Default:="2022/5", Type:=2)
'キャンセルボタンを押したとき、日付でないデータの時は終了する
If x = "False" Or Not IsDate(x) Then
MsgBox "終了しました"
End
End If
myDate = DateValue(x)
End Sub
2022/08/02 19:32頃、一部修正
（隠居Z） 2022/08/02(火) 19:00
日付を配列で処理されている(Sub arymk)ので
中身がスキルの無い私には難しいコードになっていますが勉強になります。
又、印刷部分(Sub myprintsetup)まで作成いただき感謝いたします。
改造して表示を中央揃え、歴を和暦に変更させて利用させていただきました。
大変長くなりましたが、
最後に有意義な回答を頂いた皆様に改めてお礼申し上げます。
（KonNo） 2022/08/03(水) 05:56
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.