目安箱 IV

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

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

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

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

【89】Re:一応、全部?の祝日です。
Excel  ponpon E-MAIL  - 05/3/6(日) 20:53 -

引用なし
パスワード
   ponponです。
 春分の日=DATE($B$1,3,DAY(INT(20.8431+0.242194*($B$1-1980) _
      -INT(($B$1-1980)/4))))
 

 秋分の日=DATE($B$1,9,DAY(INT(23.2488+0.242194*($B$1-1980)- _
     INT(($B$1-1980)/4))))

確か2100年までいけたと思います。(死んでるので意味ないですが)

【138】祝日表作成時の振替休日について
Excel  Jaka  - 06/2/21(火) 13:50 -

引用なし
パスワード
   5/3の振替休日があるのか解らないけど(国民の休日とダブル)
ダブって書いてもMATCHやCOUNTIFで、エラーかどうかや0より大きいかどうかで判定させると思うので複数あっても問題はないと思います。

振替休日が発生する固定祝日は下記だけ見たいですから、
こんな感じに別セルに休日を追加してやればいいと思います。

=IF(WEEKDAY(A1)=1,A1+1,"")

--------------
元日     2006/01/01
建国記念の日 2006/02/11
春分の日   2006/03/21
みどりの日  2006/04/29
憲法記念日  2006/05/03
こどもの日  2006/05/05
秋分の日   2006/09/23
文化の日   2006/11/03
勤労感謝の日 2006/11/23
天皇誕生日  2006/12/23

(注)春分、秋分の日は、2006年の場合。
--------------

9月の国民の休日は、第3月曜と秋分の日が絡むだけ見たい?だから、
単純に秋分の日が水曜なら火曜が国民の休日といった単純発想でよければ、

=IF(WEEKDAY(秋分の日)=4,秋分の日-1,"")

【146】カレンダーコントロールみたなような・・・...
Excel  Jaka  - 06/5/22(月) 12:55 -

引用なし
パスワード
   2003年以降からしか考えてないけど、カレンダーコントロールみたいな感じ?

フォーム(UserForm1)
クラス(Class1)
標準モジュール

を作って、各モジュールに下記コードをコピペ。
その後、フォームをShowすればいいです。(フォームShowのコードは自分で書いてください。)
フォーム上のコントロールは、自動で作ってくれます。

全部いっしょに書き込もうとすると10000文字制限に引っかたので、標準モジュールのコードは、この下に書きます。
ここは、フォームとクラスだけ。


フォームモジュール

Dim FMCls1() As New Class1
Dim FMCls2() As New Class1
Dim Cmb1 As New Class1
Dim Cmb2 As New Class1

Private Sub UserForm_Activate()
  Dim NwN As Date, Nwy As Long, NwM As Long
  Dim INDXY As Variant, INDXM As Variant
  NwN = Now()
  Nwy = Year(NwN)
  NwM = Month(NwN)
  INDXY = Application.Match(Nwy, Me.Controls("ComboBox1").List, 0)
  INDXM = Application.Match(NwM, Me.Controls("ComboBox2").List, 0)
  Me.Controls("ComboBox1").ListIndex = INDXY - 1
  Me.Controls("TextBox1").Value = 1
  Me.Controls("ComboBox2").ListIndex = INDXM - 1
End Sub

Private Sub UserForm_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
  For i = 1 To UBound(FMCls1)
    Me.Controls("LabelB" & i).SpecialEffect = fmSpecialEffectFlat
  Next
End Sub

Private Sub UserForm_Initialize()
  Const BHei As Double = 15, BWid As Double = 17
  Const BBTp As Double = 15, BBLt As Double = 17
  Dim ComboBox1追加 As Control, ComboBox2追加 As Control
  Dim LabelTx追加 As Control, LabelB追加 As Control, TextBox1追加 As Control
  Dim i As Long, ii As Long, Youbi As Variant, FMCNT As Long
  Dim Btop As Double, BLft As Double, CT As Long

  Me.Top = 100
  Me.Left = 300
  Me.Width = 150
  Me.Height = 160
  Me.Caption = "カレンダー"
  Youbi = Array("日", "月", "火", "水", "木", "金", "土")

  Set ComboBox1追加 = Me.Controls.Add("Forms.ComboBox.1", "ComboBox1")
  Set Cmb1.ComboBox1ChangeEvent = ComboBox1追加
  With ComboBox1追加
    .Width = 60
    .Height = 17
    .Top = 3
    .Left = 13
    .List = Array(2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, _
           2011, 2012, 2013, 2014, 2015)
    .FontSize = 11
    .Font.Bold = True
    .Style = fmStyleDropDownList
  End With
  Set ComboBox2追加 = Me.Controls.Add("Forms.ComboBox.1", "ComboBox2")
  Set Cmb1.ComboBox2ChangeEvent = ComboBox2追加
  With ComboBox2追加
    .Width = 40
    .Height = 17
    .Top = 3
    .Left = 92
    .List = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12)
    .FontSize = 11
    .Font.Bold = True
    .Style = fmStyleDropDownList
    .SetFocus
    .ListRows = 12
  End With

  Btop = 30
  For i = 1 To 7
    BLft = 13
    For ii = 1 To 7
      CT = CT + 1
      Set LabelB追加 = Me.Controls.Add("Forms.Label.1", "LabelB" & CT)
      With Me.Controls("LabelB" & CT)
        .Width = BWid
        .Height = BHei
        .Top = Btop
        .Left = BLft
        .Font.Name = "MS Pゴシック"
        .Font.Bold = True
        .TextAlign = 2
        .SpecialEffect = fmSpecialEffectFlat
        If i = 1 Then
          .Caption = Youbi(ii - 1)
          .FontSize = 10
        Else
          ReDim Preserve FMCls1(1 To CT)
          Set FMCls1(CT).LabelClickEvent = LabelB追加
          ReDim Preserve FMCls2(1 To CT)
          Set FMCls2(CT).LabelMoveEvent = LabelB追加
          .FontSize = 10
        End If
        If ii = 1 Then
          .ForeColor = &HFF&
        ElseIf ii = 7 Then
          .ForeColor = &HFF0000
        End If
      End With
      BLft = BLft + BBLt
    Next
    Btop = Btop + BHei
  Next

  Set TextBox1追加 = Me.Controls.Add("Forms.TextBox.1", "TextBox1")
  With TextBox1追加
    .Width = 5
    .Height = 5
    .Top = 0
    .Left = 0
    .Value = 0
    .FontSize = 5
    .Visible = False
  End With
  DoEvents
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
  For i = 1 To UBound(FMCls1)
    Set FMCls1(i).LabelClickEvent = Nothing
    Set FMCls2(i).LabelMoveEvent = Nothing
  Next
End Sub

=================================
クラスモジュール(名前は、Class1)

Public WithEvents LabelClickEvent As MSForms.Label
Public WithEvents ComboBox1ChangeEvent As MSForms.ComboBox
Public WithEvents ComboBox2ChangeEvent As MSForms.ComboBox
Public WithEvents LabelMoveEvent As MSForms.Label

Private Sub LabelMoveEvent_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, _
                   ByVal X As Single, ByVal Y As Single)
  LabelMoveEvent.SpecialEffect = fmSpecialEffectEtched
  For i = 8 To 49
    If LabelMoveEvent.Name <> "LabelB" & i Then
      UserForm1.Controls("LabelB" & i).SpecialEffect = fmSpecialEffectFlat
    End If
  Next
  DoEvents
End Sub

Private Sub LabelClickEvent_Click()
  Dim Conm As String, Nen As Long, Tuki As Long
  Conm = LabelClickEvent.Name
  With UserForm1
    .Controls(Conm).SpecialEffect = fmSpecialEffectSunken
    With .Controls("ComboBox1")
       If .ListIndex >= 0 Then
        Nen = .List(.ListIndex)
       End If
    End With
    With .Controls("ComboBox2")
       If .ListIndex >= 0 Then
        Tuki = .List(.ListIndex)
       End If
    End With
    MsgBox Format(Nen & "/" & Tuki & "/" & LabelClickEvent.Caption, _
           "ggge年m月d日 (aaa)"), , "選択した日付"
    .Controls(Conm).SpecialEffect = fmSpecialEffectEtched
  End With
End Sub

Private Sub ComboBox1ChangeEvent_Change()
  Dim Conm As String, Nen As Long, Tuki As Long, CT As Long
  Dim ClendHol As Variant, Clendday As Variant, i As Long
  Dim Nengetu As Date, WeekHantei As Variant
  Conm = ComboBox1ChangeEvent.Name
  With UserForm1
    If .Controls("TextBox1").Value <> "1" Then Exit Sub
    With .Controls("ComboBox1")
      Nen = .List(.ListIndex)
    End With
    With .Controls("ComboBox2")
      Tuki = .List(.ListIndex)
    End With
    ClendHol = HolidayTBL(Nen, Tuki)
    Clendday = ClendTBL(Nen, Tuki)
    CT = 0
    For i = 1 To 49
      If i > 7 Then
        CT = CT + 1
        With .Controls("LabelB" & i)
          .SpecialEffect = fmSpecialEffectFlat
          If Clendday(CT) <> "0" Then
           .Caption = Clendday(CT)
           .Enabled = True
           Nengetu = Nen & "/" & Tuki & "/" & Clendday(CT)
           WeekHantei = Application.Match(Clendday(CT), ClendHol, 0)
           If Weekday(Nengetu) = 1 Or Not IsError(WeekHantei) Then
             .ForeColor = &HFF&
           ElseIf Weekday(Nengetu) = 7 Then
             .ForeColor = &HFF0000
           Else
             .ForeColor = &H0&
           End If
           If Nengetu = Format(Now(), "yyyy/m/d") Then
             .SpecialEffect = fmSpecialEffectEtched
           End If
          Else
           .Caption = ""
           .Enabled = False
          End If
        End With
      End If
    Next
  End With
  Erase ClendHol, Clendday
  DoEvents
End Sub

Private Sub ComboBox2ChangeEvent_Change()
  Dim Nen As Long, Tuki As Long, i As Long, CT As Long
  Dim ClendHol As Variant, Clendday As Variant
  Dim Nengetu As String, WeekHantei As Variant
  With UserForm1
   If .Controls("TextBox1").Value <> "1" Then Exit Sub
   With .Controls("ComboBox1")
     Nen = .List(.ListIndex)
   End With
   With .Controls("ComboBox2")
     Tuki = .List(.ListIndex)
   End With
   ClendHol = HolidayTBL(Nen, Tuki)
   Clendday = ClendTBL(Nen, Tuki)
   CT = 0
   For i = 1 To 49
    If i > 7 Then
       CT = CT + 1
      With .Controls("LabelB" & i)
        .SpecialEffect = fmSpecialEffectFlat
        If Clendday(CT) <> "0" Then
         .Caption = Clendday(CT)
         .Enabled = True
         Nengetu = Nen & "/" & Tuki & "/" & Clendday(CT)
         WeekHantei = Application.Match(Clendday(CT), ClendHol, 0)
         If Weekday(Nengetu) = 1 Or Not IsError(WeekHantei) Then
          .ForeColor = &HFF&
         ElseIf Weekday(Nengetu) = 7 Then
          .ForeColor = &HFF0000
         Else
          .ForeColor = &H0&
         End If
         If Nengetu = Format(Now(), "yyyy/m/d") Then
          .SpecialEffect = fmSpecialEffectEtched
         End If
        Else
         .Caption = ""
         .Enabled = False
        End If
       End With
       DoEvents
    End If
   Next
  End With
  Erase ClendHol, Clendday
  DoEvents
End Sub

【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

【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月は位置をづらして入れ替えてあります

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

【220】修正点
Excel  Jaka  - 07/12/5(水) 12:44 -

引用なし
パスワード
   2008年のカレンダーを見て、勘違いしていたところです。

>   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 5
     FixHoliday = Array(3, 4, 5)
     If Nen >= 2007 Then
      GWD = 3  '変数 GWDの定義も追加しておいてください。型は、数値型
     Else
      GWD = 1
     End If
     If Weekday(Nen & "/" & Tuki & "/" & 5) <= GWD Then
      ReDim Preserve FixHoliday(UBound(FixHoliday) + 1)
      FixHoliday(UBound(FixHoliday)) = 6
     End If

【221】祝日表をまとめてみた。
Excel  Jaka  - 07/12/6(木) 9:45 -

引用なし
パスワード
   B1に西暦年号が入るとして

B4〜B29
元日
振替
成人の日
建国記念の日
振替
春分日
振替
昭和の日
振替
憲法記念日
みどりの日
こどもの日
振替
海の日
敬老の日
国民の休日
秋分の日
振替
体育の日
文化の日
振替
勤労感謝の日
振替
天皇誕生日
振替
年末年始


C4〜C29
=DATE($B$1,1,1)
=IF(WEEKDAY(C4,1)=1,C4+1,"")
=DATE($B$1,1,IF(2>=WEEKDAY(DATE($B$1,1,1),1),2-WEEKDAY(DATE($B$1,1,1),1)+((2-1)*7)+1,8-WEEKDAY(DATE($B$1,1,1),1)+((2-1)*7)+2))
=DATE($B$1,2,11)
=IF(WEEKDAY(C7,1)=1,C7+1,"")
=DATE($B$1,3,DAY(INT(20.8431+0.242194*($B$1-1980)-INT(($B$1-1980)/4))))
=IF(WEEKDAY(C9,1)=1,C9+1,"")
=DATE($B$1,4,29)
=IF(WEEKDAY(C11,1)=1,C11+1,"")
=DATE($B$1,5,3)
=DATE($B$1,5,4)
=DATE($B$1,5,5)
=IF(WEEKDAY(C15,1)<4,C15+1,"")
=DATE($B$1,7,IF(2>=WEEKDAY(DATE($B$1,7,1),1),2-WEEKDAY(DATE($B$1,7,1),1)+((3-1)*7)+1,8-WEEKDAY(DATE($B$1,7,1),1)+((3-1)*7)+2))
=DATE($B$1,9,IF(2>=WEEKDAY(DATE($B$1,9,1),1),2-WEEKDAY(DATE($B$1,9,1),1)+((3-1)*7)+1,8-WEEKDAY(DATE($B$1,9,1),1)+((3-1)*7)+2))
=IF(WEEKDAY(C20)=4,C20-1,"")
=DATE($B$1,9,DAY(INT(23.2488+0.242194*($B$1-1980)-INT(($B$1-1980)/4))))
=IF(WEEKDAY(C20,1)=1,C20+1,"")
=DATE($B$1,10,IF(2>=WEEKDAY(DATE($B$1,10,1),1),2-WEEKDAY(DATE($B$1,10,1),1)+((2-1)*7)+1,8-WEEKDAY(DATE($B$1,10,1),1)+((2-1)*7)+2))
=DATE($B$1,11,3)
=IF(WEEKDAY(C23,1)=1,C23+1,"")
=DATE($B$1,11,23)
=IF(WEEKDAY(C25,1)=1,C25+1,"")
=DATE($B$1,12,23)
=IF(WEEKDAY(C27,1)=1,C27+1,"")
=DATE($B$1,12,31)

【227】Re:祝日表をまとめてみた。
全般  VBWASURETA  - 08/1/24(木) 9:57 -

引用なし
パスワード
   ▼Jaka さん:

こんにちは。
因みに曜日は簡単に取得できたりします。
もしかすると、知っておられるかも知れませんけど^^;

Dim WeekDay As String
WeekDay = Format(Now(), "aaa")

これはアクセス、エクセル、VB共通です。


但しエクセルのシート上の関数は

=Text(Now,"aaa")

になる特殊な場合もあります。

【267】表に位置について。
Excel  Jaka  - 11/2/14(月) 16:59 -

引用なし
パスワード
   上記祝祭日表の位置が気に食わなかったら、1度下記セルに貼り付けてから、
列や行を削除するなり、移動させれば良いです。
参照先も自動で変更されます。

B1
B4〜B29
C4〜C29

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