目安箱 IV

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

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

┃ ┃ ┃ ┃ ┃ ┃

142 / 277

←次へ　｜　前へ→

【147】標準モジュールのコード

Jaka - 06/5/22(月) 12:56 -


	引用なし

	パスワード

全部いっしょに書き込もうとすると１００００文字制限に引っかたので、標準モジュールのコードはこちらに書きます。

標準モジュール

Function HolidayTBL(Nen As Long, Tuki As Long) As Variant
　 Dim FixHoliday As Variant, WekDy As Long
　 Dim Anp As Variant, CagJan As Long, CagJul As Long, CagSep As Long
　 Dim Equx39 As Long
　 Select Case Tuki
　　　Case 1
　　　　 FixHoliday = Array(1)
　　　　 If Weekday(Nen & "/" & Tuki & "/" & FixHoliday(0)) = 1 Then
　　　　　　ReDim Preserve FixHoliday(1)
　　　　　　FixHoliday(1) = Val(FixHoliday(0) + 1)
　　　　 End If
　　　　 ReDim Preserve FixHoliday(UBound(FixHoliday) + 1)
　　　　 FixHoliday(UBound(FixHoliday)) = Val(Hendo(Nen, Tuki, 2))
　　　Case 2
　　　　 FixHoliday = Array(11)
　　　　 If Weekday(Nen & "/" & Tuki & "/" & FixHoliday(0)) = 1 Then
　　　　　　ReDim Preserve FixHoliday(1)
　　　　　　FixHoliday(1) = Val(FixHoliday(0) + 1)
　　　　 End If
　　　Case 3
　　　　 Equx39 = Fix(20.8431 + 0.242194 * (Nen - 1980) - Fix((Nen - 1980) / 4))
　　　　 FixHoliday = Array(Equx39)
　　　　 If Weekday(Nen & "/" & Tuki & "/" & FixHoliday(0)) = 1 Then
　　　　　　ReDim Preserve FixHoliday(1)
　　　　　　FixHoliday(1) = Val(Equx39 + 1)
　　　　 End If
　　　Case 4
　　　　 FixHoliday = Array(29)
　　　　 If Weekday(Nen & "/" & Tuki & "/" & FixHoliday(0)) = 1 Then
　　　　　　ReDim Preserve FixHoliday(1)
　　　　　　FixHoliday(1) = Val(FixHoliday(0) + 1)
　　　　 End If
　　　Case 5
　　　　 FixHoliday = Array(3, 4, 5)
　　　　 If Weekday(Nen & "/" & Tuki & "/" & FixHoliday(2)) = 1 Then
　　　　　　ReDim Preserve FixHoliday(UBound(FixHoliday) + 1)
　　　　　　FixHoliday(UBound(FixHoliday)) = Val(FixHoliday(2) + 1)
　　　　 End If
　　　Case 7
　　　　 FixHoliday = Array(Val(Hendo(Nen, Tuki, 3)))
　　　Case 9
　　　　 FixHoliday = Array(Val(Hendo(Nen, Tuki, 3)))
　　　　 Equx39 = Fix(23.2488 + 0.242194 * (Nen - 1980) - Fix((Nen - 1980) / 4))
　　　　 ReDim Preserve FixHoliday(1)
　　　　 FixHoliday(1) = Equx39
　　　　 If Weekday(Nen & "/" & Tuki & "/" & Equx39) = 4 Then
　　　　　　ReDim Preserve FixHoliday(UBound(FixHoliday) + 1)
　　　　　　FixHoliday(UBound(FixHoliday)) = Val(Equx39 - 1)
　　　　 End If
　　　　 If Weekday(Nen & "/" & Tuki & "/" & FixHoliday(1)) = 1 Then
　　　　　　ReDim Preserve FixHoliday(UBound(FixHoliday) + 1)
　　　　　　FixHoliday(UBound(FixHoliday)) = Val(Equx39 + 1)
　　　　 End If
　　　Case 10
　　　　 FixHoliday = Array(Val(Hendo(Nen, Tuki, 2)))
　　　Case 11
　　　　 FixHoliday = Array(3, 23)
　　　　 If Weekday(Nen & "/" & Tuki & "/" & FixHoliday(0)) = 1 Then
　　　　　　ReDim Preserve FixHoliday(UBound(FixHoliday) + 1)
　　　　　　FixHoliday(UBound(FixHoliday)) = Val(FixHoliday(0) + 1)
　　　　 End If
　　　　 If Weekday(Nen & "/" & Tuki & "/" & FixHoliday(1)) = 1 Then
　　　　　　ReDim Preserve FixHoliday(UBound(FixHoliday) + 1)
　　　　　　FixHoliday(UBound(FixHoliday)) = Val(FixHoliday(1) + 1)
　　　　 End If
　　　Case 12
　　　　 FixHoliday = Array(23)
　　　　 If Weekday(Nen & "/" & Tuki & "/" & FixHoliday(0)) = 1 Then
　　　　　　ReDim Preserve FixHoliday(1)
　　　　　　FixHoliday(1) = Val(FixHoliday(0) + 1)
　　　　 End If
　　　Case 6, 8
　　　　 FixHoliday = Array(0)
　 End Select
　 HolidayTBL = FixHoliday
　 Erase FixHoliday
　 DoEvents
End Function

Function ClendTBL(Nen As Long, Tuki As Long) As Variant
　 Dim TBL(1 To 42) As Long, CT As Long, i As Long
　 Dim StDay As Long, Edday As Long
　 StDay = Weekday(Nen & "/" & Tuki & "/1")
　 'Edday = Format(DateSerial(Nen, Tuki + i, 1) - 1, "d")
　 Edday = Format(DateSerial(Nen, Tuki + 1, 0), "d")
　 CT = 0
　 For i = StDay To StDay - 1 + Edday
　　　 CT = CT + 1
　　　 TBL(i) = CT
　 Next
　 ClendTBL = TBL
　 Erase TBL
End Function

Function Hendo(Nen As Long, Tuki As Long, SacWek As Long) As Long
　 Dim HolSt As Long, WekDy As Integer
　 WekDy = Weekday(Nen & "/" & Tuki & "/1", vbSunday)
　 If WekDy <= 2 Then
　　 HolSt = 2 - WekDy + ((SacWek - 1) * 7) + 1
　 Else
　　 HolSt = 8 - WekDy + ((SacWek - 1) * 7) + 2
　 End If
　 Hendo = HolSt
End Function

5,627 hits