目安箱 IV

目安箱投稿のルールはこちらをごらんください。
ご意見は電子メールで承っています。
「目安箱」は質問禁止です。技術的な質問はそれぞれの質問箱へどうぞ。

迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。

┃ ┃ ┃ ┃ ┃ ┃

117 / 277

←次へ　｜　前へ→

【173】７×７マスのカレンダー

Jaka - 06/12/26(火) 10:16 -


	引用なし

	パスワード

全ての月（曜を日含む、7×7マス）の位置を一々決めなければならない手間がありますが、マスの位置をの変則に好き勝手な場所に設定できるようにこんな感じにしてみました。
Ｂ１セルに年号が入っているとします。
年号の不具合チェックはしてません。
祝日、振替休日も入れてません。
土日だけ色を変えました。
一応罫線も入ってます。

Sub カレンダー3()
　Const 一月 As String = "B4:H10", 二月 As String = "K4:Q10", 三月 As String = "B14:H20"
　Const 四月 As String = "K14:Q20", 五月 As String = "B24:H30", 六月 As String = "K24:Q30"
　Const 七月 As String = "B34:H40", 八月 As String = "K34:Q40", 九月 As String = "B44:H50"
　Const 十月 As String = "K44:Q50", 十一月 As String = "M53:S59", 十二月 As String = "B55:H61"

　Dim TB(0 To 5, 0 To 6), RgTB As Variant, WekN As Long, YMD_C As Date
　Dim Rgst1 As Variant, Rgst2 As String, WeekTL As Variant, Ct As Long
　Dim Nen As Long, EndD As Long, No As Long, WkRwo As Long, WkCol As Long

　WeekTL = Array("日", "月", "火", "水", "木", "金", "土")
　RgTB = Array(一月, 二月, 三月, 四月, 五月, 六月, _
　　　　　　　七月, 八月, 九月, 十月, 十一月, 十二月)
　Application.ScreenUpdating = False
　Nen = Range("B1").Cells(1).Value　　'B1に年号が入っているとして。
　　　　　　　　　　　　　　　　　　　'B1が結合セルの左上に値すれば、結合セル可。
　Range("B2:T62").Clear 'Cells.Clear
　'Range("B2:T62").ClearComments　 '変動祝日を休日表無しで、条件付書式にした場合
　Range("B1").Cells(1).Value = Nen

　For Each Rgst1 In RgTB
　　 Ct = Ct + 1
　　 YMD_C = Nen & "/" & Ct & "/1"
　　 WekN = Weekday(YMD_C)
　　 EndD = Day(DateSerial(Year(YMD_C), Month(YMD_C) + 1, 0))
　　 With Range(Rgst1)
　　　　 '月
　　　　 .Cells(1).Offset(-1).Value = Month(YMD_C) & "月"
　　　　 '週タイトル記入、文字センター、色黄色
　　　　 With .Rows(1)
　　　　　　 .Value = WeekTL
　　　　　　 .Rows(1).HorizontalAlignment = xlCenter
　　　　　　 .Rows(1).Interior.ColorIndex = 6
　　　　 End With
　　　　 .Columns(1).Font.ColorIndex = 3　'文字赤
　　　　 .Columns(7).Font.ColorIndex = 41 '文字青
　　　　 'セル範囲タイトル分縮小
　　　　 Rgst2 = .Resize(.Rows.Count - 1).Offset(1).Address(0, 0)
　　　　 With Range(Rgst2)
　　　　　　 For i = 0 To EndD - 1
　　　　　　　　No = WekN + i - 1
　　　　　　　　WkRwo = Fix(No / 7)
　　　　　　　　WkCol = No Mod 7
　　　　　　　　TB(WkRwo, WkCol) = i + 1
　　　　　　 Next
　　　　　　 .Value = TB
　　　　 End With
　　 End With
　　 Erase TB
　　 Call 罫線22(CStr(Rgst1))
　Next
　WeekTL = Empty: RgTB = Empty
　Application.ScreenUpdating = True
End Sub

Sub 罫線22(Rgst As String)
　With Range(Rgst)
　　　'.Borders.LineStyle = 1 'OK
　　　 .Borders.Weight = 2 'xlThick普通=2 'xlMedium太線=3
　　　　　　　　　　　　　 'xlHairline細=1 'xlThick極太線=4
　　　 .Rows(1).BorderAround (9)
　　　 .BorderAround (1)　'細=0 普通=1 点線1=2 点線2=3 点線3=4 点線4=5
　　　　　　　　　　　　　'普通=6,7,8,10,11,12 ２重=9
　　　　　　　　　　　　　'太斜点=13　14X 15X 16X 17X 18X 19X 20X
　End With
End Sub

4,391 hits