目安箱 IV

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

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

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃ホーム  
127 / 262 ←次へ | 前へ→

【147】標準モジュールのコード
Excel  Jaka  - 06/5/22(月) 12:56 -

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

標準モジュール

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,043 hits

【37】不特定な祝日を求めるエクセル関数とマクロ関数。 Jaka 03/10/28(火) 11:29 Excel[未読]
【38】文中間違い訂正。 Jaka 03/10/29(水) 12:14 Excel[未読]
【59】[管理者削除] [未読]
【88】一応、全部?の祝日です。 Jaka 05/2/28(月) 11:27 Excel[未読]
【89】Re:一応、全部?の祝日です。 ponpon 05/3/6(日) 20:53 Excel[未読]
【138】祝日表作成時の振替休日について Jaka 06/2/21(火) 13:50 Excel[未読]
【146】カレンダーコントロールみたなような・・・。 Jaka 06/5/22(月) 12:55 Excel[未読]
【147】標準モジュールのコード Jaka 06/5/22(月) 12:56 Excel[未読]
【173】7×7マスのカレンダー Jaka 06/12/26(火) 10:16 Excel[未読]
【182】祝祭日も入れてみた。 Jaka 07/1/9(火) 9:53 Excel[未読]
【187】↑の注意点。 Jaka 07/1/31(水) 10:46 Excel[未読]
【220】修正点 Jaka 07/12/5(水) 12:44 Excel[未読]
【221】祝日表をまとめてみた。 Jaka 07/12/6(木) 9:45 Excel[未読]
【227】Re:祝日表をまとめてみた。 VBWASURETA 08/1/24(木) 9:57 全般[未読]
【267】表に位置について。 Jaka 11/2/14(月) 16:59 Excel[未読]

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃ホーム  
127 / 262 ←次へ | 前へ→
ページ:  ┃  記事番号:   
0
(SS)C-BOARD v3.8 is Free