| |
ゴミが残っていたので再アップ。
２００６年に決まった？らしい、２００７年から実行される？祝日の変更が、９月の秋分の日、第３月曜が絡むとどうなるのかわからなくて、昨年アップしたものを１度消しましたが、詳しくはやっぱり解りませんでした。（昨年のものとほとんど同じ
改正された新国民の休日が反映されるのは、２００８年の５月からみたいです。（２００９年にも反映されている。）
５月の新国民の休日判定は、なんとなく５/５が日曜〜水曜なら、６日に休みになるといった、よく解らない方法で判定してます。
祝日が休日の場合、翌日に振り返ることができますが、翌日が祝日だった場合？最初の祝日を繰り越せるとかよく解りませんでした。
ということですので、こういった手法もあるということでお願いします。
祝日の変更もしやすいと思います。
間違いに気づいた方、修正お願いします。
２００３年以前の事は全く考えてません。
B1に年号が入っているとして...（エラー処理は、入れてません。）
セルB1に年号が入ってないとエラーになります。
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"
↑ ↑
'11月と12月は位置をづらして入れ替えてあります
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
Dim HoriChk As Variant, Hrd As Variant
WeekTL = Array("日", "月", "火", "水", "木", "金", "土")
RgTB = Array(一月, 二月, 三月, 四月, 五月, 六月, _
七月, 八月, 九月, 十月, 十一月, 十二月)
Application.ScreenUpdating = False
Nen = Range("B1").Cells(1).Value 'B1に年号が入っているとして。
'B1が結合セルの左上に値すれば、結合セル可。
Range("B2:T62").Clear 'Cells.Clear
'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
'祝日＆振替文字色 赤
HoriChk = Application.Run("HorTB_M" & Ct, Nen)
If IsArray(HoriChk) Then
For Each Hrd In HoriChk
If Hrd > 0 Then
.Cells(Hrd + WekN - 1).Font.ColorIndex = 3
End If
Next
Erase HoriChk
End If
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
Sub test()
'変数 = Application.Run("Book1!Runtest", 変数)
dd = 2006
aa = Application.Run("HorTB_M" & 9, dd)
MsgBox aa(UBound(aa))
End Sub
Private Function HorTB_M1(Nen As Long) As Variant
Dim Hori As Long, WekDy As Long
WekDy = Weekday(Nen & "/1/1", vbSunday)
If WekDy = 1 Then
Hori = 2
End If
If WekDy <= 2 Then
Hori2 = 2 - WekDy + ((2 - 1) * 7) + 1
Else
Hori2 = 8 - WekDy + ((2 - 1) * 7) + 2
End If
HorTB_M1 = Array(1, Hori, Hori2)
End Function
Private Function HorTB_M2(Nen As Long) As Variant
Dim Hori As Long
Hori = 11
If Weekday(Nen & "/3/" & Hori, vbSunday) = 1 Then
Hori = Hori + 1
End If
HorTB_M2 = Array(Hori)
End Function
Private Function HorTB_M3(Nen As Long) As Variant
Dim Hori As Long
Hori = Fix(20.8431 + 0.242194 * _
(Nen - 1980) - Fix((Nen - 1980) / 4))
If Weekday(Nen & "/" & 3 & "/" & Hori, vbSunday) = 1 Then
Hori = Hori + 1
End If
HorTB_M3 = Array(Hori)
End Function
Private Function HorTB_M4(Nen As Long) As Variant
Dim Hori As Long
Hori = 29
If Weekday(Nen & "/4/29", vbSunday) = 1 Then
Hori = Hori + 1
End If
HorTB_M4 = Array(Hori)
End Function
Private Function HorTB_M5(Nen As Long) As Variant
Dim Hori As Long
Hori = 0
'2007からの国民の休日もつもり
If Nen >= 2007 And Weekday(Nen & "/" & "5/5", vbSunday) < 4 Then
Hori = 6
ElseIf Weekday(Nen & "/5/5", vbSunday) = 1 Then
Hori = 6
End If
HorTB_M5 = Array(3, 4, 5, Hori) '日曜とのダブりは、無視。
End Function
Private Function HorTB_M6(Nen As Long) As Variant
HorTB_M6 = Empty
End Function
Private Function HorTB_M7(Nen As Long) As Variant
Dim Hori As Long, WekDy As Long
WekDy = Weekday(Nen & "/7/1", vbSunday)
If WekDy <= 2 Then
Hori = 2 - WekDy + ((3 - 1) * 7) + 1
Else
Hori = 8 - WekDy + ((3 - 1) * 7) + 2
End If
If Weekday(Nen & "/4/" & Hori, vbSunday) = 1 Then
Hori = Hori + 1
End If
HorTB_M7 = Array(Hori)
End Function
Private Function HorTB_M8(Nen As Long) As Variant
HorTB_M8 = Empty
End Function
Private Function HorTB_M9(Nen As Long) As Variant
Dim Hori As Long, Hori2 As Long, WekDy As Long
WekDy = Weekday(Nen & "/9/1", vbSunday)
If WekDy <= 2 Then
Hori = 2 - WekDy + ((3 - 1) * 7) + 1
Else
Hori = 8 - WekDy + ((3 - 1) * 7) + 2
End If
Hori2 = Fix(23.2488 + 0.242194 * _
(Nen - 1980) - Fix((Nen - 1980) / 4))
If Weekday(Nen & "/9/" & Hori2, vbSunday) = 1 Then
HorTB_M9 = Array(Hori, Hori2 + 1)
ElseIf Weekday(Nen & "/9/" & Hori2, vbSunday) = 4 Then
HorTB_M9 = Array(Hori, Hori2 - 1, Hori2)
Else
HorTB_M9 = Array(Hori, Hori2)
End If
End Function
Private Function HorTB_M10(Nen As Long) As Variant
Dim Hori As Long, WekDy As Long
WekDy = Weekday(Nen & "/10/1", vbSunday)
If WekDy <= 2 Then
Hori = 2 - WekDy + ((2 - 1) * 7) + 1
Else
Hori = 8 - WekDy + ((2 - 1) * 7) + 2
End If
HorTB_M10 = Array(Hori)
End Function
Private Function HorTB_M11(Nen As Long) As Variant
Dim Hori As Long, Hori2 As Long
Hori = 3
If Weekday(Nen & "/" & "11/3", vbSunday) = 1 Then
Hori = Hori + 1
End If
Hori2 = 23
If Weekday(Nen & "/" & "11/23", vbSunday) = 1 Then
Hori2 = Hori2 + 1
End If
HorTB_M11 = Array(Hori, Hori2)
End Function
Private Function HorTB_M12(Nen As Long) As Variant
Dim Hori
Hori = 23
If Weekday(Nen & "/" & "12/23", vbSunday) = 1 Then
Hori = Hori + 1
End If
HorTB_M12 = Array(Hori)
End Function
|
|
![[未読]](./data/FAQ/image/read_icon.gif){kind=icon}
