Results of 1 - 1 of about 1242 for カレンダー (0.001 sec.)
- [[20220801142454]]
- #score: 6118
- @digest: a11abe5b02c7f6aaa2222d47da0a98fd
- @id: 91930
- @mdate: 2022-08-02T20:56:47Z
- @size: 49939
- @type: text/plain
- #keywords: firstday (101818), inputymd (97381), calenderrownum (91726), arycalendar (88570), outputcell (87951), mytable (74205), maxweek (71506), dist (66956), konno (62711), tuki (43296), rowheight (37878), dateserial (28389), xlcenter (16822), 日リ (15593), horizontalalignment (14642), mydate (12480), font (11179), weekday (9917), 2022 (9554), カレ (9025), 年月 (8940), 休日 (8056), color (8019), ト") (7210), 曜日 (6554), 日曜 (6187), integer (6052), ・ω (5684), レン (5619), ・` (5475), 月分 (5207), month (5113)
- 『卓上カレンダーの改良』（KonNo）
以下のVBAで卓上カレンダーを作成しています。 1回で4ヶ月分を作成して、その後手動で A4（縦）1ページに2ヶ月分、2ページで4ヶ月を基本としていますが 一ヶ月が5行の場合は良いのですが、添付画像のように 6行の場合は上手く処理できていません。 コードか改良して6行の場合でも上手く 処理できるようにしたいのでアドバイスをお願いします。 参考用、添付画像 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 ---- OKさん、アドバイスありがとうございます。 参考のマクロは、月が何週まであるかをチェックして対策を立てなさいとのことですか? つまり月が5週までと6週までの2つのパターンを考えろと。。。。。 （KonNo） 2022/08/01(月) 15:16 ---- ちょい見なので。。。詳しくはわかりませんが 横に7日分表示したら、行を必要分増やせば良いだけでは 外していましたら、お許しを。。。^^; m(__)m （隠居Z） 2022/08/01(月) 15:38 ---- >つまり月が5週までと6週までの2つのパターンを考えろと。。。。。 正確にいうと4週、5週、6週の3パターンあります。 最初から6週で決め打ちする方法と必要な週分だけ 作る方法があります。 (末の週-朔日の週)*2+1 が必要な行数になります。 いろんな箇所の調整が必要ですけど。 （OK） 2022/08/01(月) 15:45 ---- 隠居Zさん、OKさん 回答感謝します 「行を必要分増やせば良いだけでは」 そうです。 参照画像を見てもらえれば判ると思いますが 1行目の最初は、日曜日から始まります。 OKさんに指摘された分かったのですが なので月によって4行、5行、6行の3パターンが存在します。 必要な行数が肝になりそうで 「(末の週-朔日の週)*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 '4ヶ月分の年月日を求める 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) '4ヶ月分の最大週数を求める 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 '--------------- 'とりあえず1ヶ月分だけ '月の行のセルの高さ 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週まである場合上手く処理できません 具体的に書いてください。 すべての場合で、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月分は第6週の作画が不完全です。 （罫線が引かれていない状況） これで卓上カレンダーのイメージが出来るでしょうか ? ＞すべての場合で、6週までの書式にしておけばいいのでは? OKさんが指摘されたように 月によって4,5,6週(4行、5行、6行）の3パターンが存在します。 6週で固定すれば、4,5週の場合 不用な空白を含む罫線が作画されてしまうと思われます。 '----------------------- γさん、コードの提示ありがとうございます。 コードを追いかけるのに少し時間を下さい。 ＞どの月も6週ある前提で固定の行数にあてはめたほうがよかったかも? 6週で固定すれば、4,5週の場合 不用な空白を含む罫線が作画されてしまいませんか ? （KonNo） 2022/08/02(火) 10:12 ---- 6週に固定しないと、 レイアウトがころころ変わりませんか? 不要な空白が多くなるのはわかりますが、 空白は不可避ですので気にしなければいいかと。 というか私のエクセル2019には、 「どの年度にも対応する月単位のカレンダー」 というのがテンプレートに入っていますが、 それを使えば比較的容易に希望するカレンダーが作れそうな気がします。 様式もほぼ同じですし。 それを直せば、マクロ無しで期待した雛形が作れそうな気がします。 数式が残るのが嫌なら、マクロ付きテンプレートにして、新しく保存するときに 数式を値に変えるマクロだけ作るというアプローチもあるかと思います。 もちろん新たに保存するときまマクロ無し保存にします。 一案として。。。。 （まっつわん） 2022/08/02(火) 10:36 ---- >質問の最初に添付した画像を参照下さい。 いや、だから... >6週で固定すれば、4,5週の場合 >不用な空白を含む罫線が作画されてしまいませんか ? それを気にしないというのも一つの答えなんですよ。 6週分固定にして、各月の最初の行位置を固定するとコード書くのが楽になります けど、余計な空白が生じるので見た目がよくない?? （とは私は思いませんが） 各月の週数に応じて次ぎの月の初めの行を可変にすると 余計な空白行は生じませんがコードはそれだけ複雑になります。 どっちとるの?という話です。 空白行（6週目の行）を非表示にするという解決策もあります。 そうすると改ページ位置は動かさなくていいのでこれが一番楽かもしれません （´・ω・`） 2022/08/02(火) 10:45 ---- あ、罫線の描画だけ可変にするというのもありです 印刷したとき、全ページで各月の位置がずれないというのは、 日本人的には書式としての受けがいいかもしれません （´・ω・`） 2022/08/02(火) 10:46 ---- まっつわん、興味を持っていただきありがとうございます。 私のPC（excel2021)をチェックしましたが 「どの年度にも対応する月単位のカレンダー」 というのがテンプレートは見つかりませんでした。 「Officeのカスタムテンプレート」フォルダーにもありませんでした。 テンプレートの拡張子である「xltx」で検索しましたが それらしきファイルを見つけられませんでした。 6週固定で不用な空白が表示されても気にしないと言う案は 正直私は気になるので6週固定で無いマクロはを作成したいと思います。 '---------------------------------- ´・ω・`さん、 6週固定で不用な空白が表示されても気にしないと言う案は 正直私は気になるので6週固定で無いマクロを作成したいと思います。 ＞空白行（6週目の行）を非表示にするという解決策もあります。 ＞ そうすると改ページ位置は動かさなくていいのでこれが一番楽かもしれません 6週分固定でコードを作成したほうがコードが複雑にならずに簡単にるのは判るような気がします。 但しその場合、空白の6週目の行が必要ないとの判断するコードや 非表示にコードを追加しなくては行けないので逆に複雑にならないのでしょうか ? （私の今のスキルではできそうにありません。） 初心者の私には、後でコードを見直したときに分かりやすいコードを目指したいと思います。 '----------------------------------- γさん、 コードを走らせてみて6週有る有る場合でも処理できました。 （4週しか無い場合の年月が不明なのでそこはチェックできていません。） 改めてお礼申し上げます。 （KonNo） 2022/08/02(火) 11:22 ---- ＞4週しか無い場合の年月 近いところでは、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 ---- わからんさん、 4週しか無い場合の年月を教えていただき感謝します。 '------------------- γさん、4週しか無い場合もチェックしてのコードだったのですね。 ご助力に頭が下がります。 卓上カレンダーは、自己用なのでおっしゃるように神経を使うものでは無く 少しDo_itを書き出せれば良いので多くは望んでいません。 ところで、先に提案の有った以下の件ですが、 ＞各月の間には一行だけ余白行を入れて、 ＞ふたつの月が終了したところに印刷改ページを入れればよいのかなあ。 つまり、m=1の場合に 現在の行に改ページを入れる事になると思うのですが 具体的にはどのようなコードになるのでしょうか ? （KonNo） 2022/08/02(火) 11:57 ---- 印刷するなら 一月ごとに表示して、都度、印刷すれば。。。 そのぉ～ 手間いらずかと思います。^^;口だけで済みません。 記録もいるなら。済みません m(_ _)m （隠居Z） 2022/08/02(火) 12:05 ---- 隠居Zさん、 1月ごとに表示、印刷では A4（縦）1ページ印刷では、下半分が利用されずに無駄となりコスパが悪くなります。 A4(縦)で2ヶ月分の現在のサイズが、印刷で丁度良い卓上サイズなのです。 （KonNo） 2022/08/02(火) 12:17 ---- マクロ記録をとればすぐにわかります。 （γ） 2022/08/02(火) 12:27 ---- KonNo さん 仰せ、御もっともです。。。m(__)m じゃぁ、どぉせ4回廻すなら、ついでに、二か月目と、 最後に印刷かけちゃうとか。。。w^^; ロジックの関係で難しければ、すみません m(__)m （隠居Z） 2022/08/02(火) 12:41 ---- Cal:最初の日付 Months:何月分記述するかの設定 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 ---- γさん、アドバイスありがとうございます。 アクティブ セルの上に水平な改ページを追加すればと思い以下のように 2箇所コード（改ページの削除 と 挿入）を追加しましたがうまく処理できていないようです。 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 ---- 隠居Zさんへ、 ＞ついでに、二か月目と、 ＞最後に印刷かけちゃうとか。。。w^^; 同じ印刷するなら印刷を2回行うより1回で済ませればその方が良くないですか ? その為、現在改ページを挿入できるようにコードを改良中です。 （KonNo） 2022/08/02(火) 12:59 ---- 長げー、長げーわ! どーでもえーことをダラダラダラダラ。 ほぼ出来たんなら、後は自分で好きなよーにせーよ。書いたコードのUPも不要! もー飽きた。 （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 1か月分のカレンダーを出力する関数(MakeMonthCalendar) そのカレンダーの書式を設定する関数(SetCalendarFormat) に分割してみました。 4か月分出力したければ、MakeMonthCalendar を4回繰り返します。 半年分とか1年分出力したいということは、繰り返し数を変更するだけですみます。 書式を変更したいというときも、SetCalendarFormatを変更すればいいだけ、 というように変更しやすくなると思います。 あくまで自分がつくるならというものですので、時間があれば研究用としてご利用ください。 （hatena） 2022/08/02(火) 13:25 ---- どの年度にも対応する月単位のカレンダー https://templates.office.com/ja-jp/%e3%81%a9%e3%81%ae%e5%b9%b4%e5%ba%a6%e3%81%ab%e3%82%82%e5%af%be%e5%bf%9c%e3%81%99%e3%82%8b%e6%9c%88%e5%8d%98%e4%bd%8d%e3%81%ae%e3%82%ab%e3%83%ac%e3%83%b3%e3%83%80%e3%83%bc-tm04014209 ↑では6週固定ですね。 セル範囲を6週固定で、あとは見せ方だけだと思うんですが。。。。ということを言いたかった。 （まっつわん） 2022/08/02(火) 13:50 ---- hatenaさん、コードをありがとうございます。 コードを走らせてみましたが、EXCELが異常終了します。 Windowsエラー報告を外部に発信しようとします。 もう一度、Excelを起動させると「ドキュメントの回復」を促す表示が出ます。 ステップ実行でエラー場所を特定していくと 以下の処理中で発生しているようです。 Public Sub SetCalendarFormat(CalendarRng As Range) 途中まで処理されているようで 添付画像のところで終わっていました。 https://imgur.com/ifhmaKh （KonNo） 2022/08/02(火) 14:02 ---- まっつわんさん、MicrosoftのテンプレートのダウンロードURLの提示ありがとうございます。 ＞セル範囲を6週固定で、あとは見せ方だけだと思うんですが。。。。ということを言いたかった。 おっしゃりたいことは、十分理解しています。 6行固定で空白が出力される問題は、個人の好き嫌いです。 （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 ---- hatenaさんへ、 さらに少し修正されたコードに入れ替えて コードを走らせてみましたが、同じくEXCELが異常終了します。 前回と同じで ステップ実行でエラー場所を特定していくと 同じく以下の処理中で発生しているようです。 Public Sub SetCalendarFormat(CalendarRng As Range) 瞬間的に異常終了するので場所が特定できていないかも知れませんが コード的には、以下の部分付近と思われます。 With .Rows(i).SpecialCells(xlCellTypeConstants) .Font.Size = 8 .VerticalAlignment = xlTop 今回も途中まで処理されているようで 今回の処理も以前の添付画像とほぼ同じように表示されています。 （KonNo） 2022/08/02(火) 14:46 ---- おおもとのカレンダー作成は http://www.eurus.dti.ne.jp/~yoneyama/Excel/vba/calendar_m.html •日付を1行おきにして、メモ欄を設ける例です。 ですよね。 （PAKURI） 2022/08/02(火) 14:50 ---- 当方のサンプルでは問題なく動いているので不思議ですね。 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 ---- hatenaさんのコード 修正前、修正後共、正常終了 カレンダーが作成されていましたですよ。。。^^; ご報告まで Excel2016 365タイプ Win 10 Home でした。 （隠居Z） 2022/08/02(火) 14:56 ---- それでは私はこのあたりで、書式は最低限です。 フォントや色はやってません 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 ---- hatenaさん、アドバイス感謝します。 PCを再起動してアドバイスにあった部分をコメントアウトして実行すると エラー無く処理されました。 '------------------ ´・ω・`さん、参考コードありがとうございます。 コードを走らせてエラー無く処理出来るのを確認できました。 まだゆっくり見直す時間が取れていませんが後でチェックしたいと思います。 ´・ω・`さんは、退席されるとの事、お付き合い願いありがとうございました。 改めてお礼申し上げます。 （KonNo） 2022/08/02(火) 15:31 ---- Option Explicit 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 ---- ＞追加してみましたがどうでしょうか ? 試しもしないで何を言うか。 （あほ） 2022/08/02(火) 17:31 ---- まだやっとったんかいな。 ほんましつこいなーこいつ。 皆さんが優しすぎるから甘やかしてしまうのでは? もう一回言う。 自分で好きなようにやれ! 人を巻き込むな!! アホちゃうかこいつ。 （NonNo） 2022/08/02(火) 17:39 ---- [[20220223092655]] 以上のスレで ＞算数の問題でしょう と、小学生レベルの算数と書かれても ＞数学的な問題と言われればその通り 中学生レベルの数学と言い換えて、難しいといってしまうような人です そういう前提で長い目で相手してあげましょう 相手をしたく無いのであればスルーすればよいです 文句をつける必要はないでしょう （とおりすがり） 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 ---- 隠居Zさん、コードをありがとうございます。 日付を配列で処理されている(Sub arymk)ので 中身がスキルの無い私には難しいコードになっていますが勉強になります。 又、印刷部分(Sub myprintsetup)まで作成いただき感謝いたします。 改造して表示を中央揃え、歴を和暦に変更させて利用させていただきました。 大変長くなりましたが、 最後に有意義な回答を頂いた皆様に改めてお礼申し上げます。 （KonNo） 2022/08/03(水) 05:56... - https://www.excel.studio-kazu.jp/wiki/kazuwiki/202208/20220801142454.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97045 documents and 608223 words.
訪問者：