目安箱 IV

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

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

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

【37】不特定な祝日を求めるエクセル関数とマクロ関数。 Jaka 03/10/28(火) 11:29 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[未読]

【173】7×7マスのカレンダー
Excel  Jaka  - 06/12/26(火) 10:16 -

引用なし
パスワード
   全ての月(曜を日含む、7×7マス)の位置を一々決めなければならない手間がありますが、マスの位置をの変則に好き勝手な場所に設定できるようにこんな感じにしてみました。
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"

 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 2重=9
             '太斜点=13 14X 15X 16X 17X 18X 19X 20X
 End With
End Sub

【182】祝祭日も入れてみた。
Excel  Jaka  - 07/1/9(火) 9:53 -

引用なし
パスワード
   ゴミが残っていたので再アップ。

2006年に決まった?らしい、2007年から実行される?祝日の変更が、9月の秋分の日、第3月曜が絡むとどうなるのかわからなくて、昨年アップしたものを1度消しましたが、詳しくはやっぱり解りませんでした。(昨年のものとほとんど同じ
改正された新国民の休日が反映されるのは、2008年の5月からみたいです。(2009年にも反映されている。)

5月の新国民の休日判定は、なんとなく5/5が日曜〜水曜なら、6日に休みになるといった、よく解らない方法で判定してます。
祝日が休日の場合、翌日に振り返ることができますが、翌日が祝日だった場合?最初の祝日を繰り越せるとかよく解りませんでした。

ということですので、こういった手法もあるということでお願いします。

祝日の変更もしやすいと思います。
間違いに気づいた方、修正お願いします。
2003年以前の事は全く考えてません。

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 2重=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

【187】↑の注意点。
Excel  Jaka  - 07/1/31(水) 10:46 -

引用なし
パスワード
   > Const 十月 As String = "K44:Q50", 十一月 As String = "M53:S59", 十二月 As String = "B55:H61"
>                             ↑              ↑
>                           '11月と12月は位置をづらして入れ替えてあります

上の「↑」が書いてある行は、コメントにしてください。
このまま試すとエラーになります。

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