目安箱 IV

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

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

┃ ┃ ┃ ┃ ┃ ┃

24 / 117 ﾂﾘｰ

←次へ　｜　前へ→

【37】不特定な祝日を求めるエクセル関数とマクロ関数。 Jaka 03/10/28(火) 11:29

【38】文中間違い訂正。 Jaka 03/10/29(水) 12:14

【59】[管理者削除]

【88】一応、全部？の祝日です。 Jaka 05/2/28(月) 11:27

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

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

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

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

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

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

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

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

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

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

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

【37】不特定な祝日を求めるエクセル関数とマクロ...

Jaka - 03/10/28(火) 11:29 -


	引用なし

	パスワード

不特定な祝日を求めるエクセル関数とマクロ関数。

検索曜日Noは、下記として。
日　月　火　水　木　金　土
１　２　３　４　５　６　７

基本（日にちだけです。）
=IF(検索曜日No>=WEEKDAY(DATE(年,月,1),1),検索曜日No-WEEKDAY(DATE(年,月,1),1)+((検索週-1)*7)+1,8-WEEKDAY(DATE(年,月,1),1)+((検索週-1)*7)+検索曜日No)

注）単純に足し算しているだけなので、存在しない２００３年８月の第６土曜日は、３６となってしまいますが、年、月、週、曜日が固定ならこれで十分だと思います。

１月の第２月曜日（成人の日）
=DATE(2003,1,IF(2>=WEEKDAY(DATE(2003,1,1),1),2-WEEKDAY(DATE(2003,1,1),1)+((2-1)*7)+1,8-WEEKDAY(DATE(2003,1,1),1)+((2-1)*7)+2))

７月の第３月曜日（海の日）
=DATE(2003,7,IF(2>=WEEKDAY(DATE(2003,7,1),1),2-WEEKDAY(DATE(2003,7,1),1)+((3-1)*7)+1,8-WEEKDAY(DATE(2003,7,1),1)+((3-1)*7)+2))

９月の第３月曜日（敬老の日）
=DATE(2003,9,IF(2>=WEEKDAY(DATE(2003,9,1),1),2-WEEKDAY(DATE(2003,9,1),1)+((3-1)*7)+1,8-WEEKDAY(DATE(2003,9,1),1)+((3-1)*7)+2))

１０月の第２月曜日（体育の日）
=DATE(2003,10,IF(2>=WEEKDAY(DATE(2003,10,1),1),2-WEEKDAY(DATE(2003,10,1),1)+((2-1)*7)+1,8-WEEKDAY(DATE(2003,10,1),1)+((2-1)*7)+2))

存在しないデータを記入し、存在しない日付を返したくない時にエラーを返したいなら。

基本
=DATEVALUE(年 & "/" & 月 & "/" & IF(検索曜日No>=WEEKDAY(DATE(年,月,1),1),検索曜日No-WEEKDAY(DATE(年,月,1),1)+((検索週-1)*7)+1,8-WEEKDAY(DATE(年,月,1),1)+((検索週-1)*7)+検索曜日No))

例　セルにデータを記入して、２００３年３月の第５、日曜日の年月日を求める。

　Ａ　　　　Ｂ　　　　Ｃ　　　　Ｄ
1　年　　　検索月　　検索週　　検索曜日
2　2003　　　3 　　　　5　　　　 1

=DATEVALUE($A$2 & "/" & $B$2 & "/" & IF($D$2>=WEEKDAY(DATE($A$2,$B$2,1),1),$D$2-WEEKDAY(DATE($A$2,$B$2,1),1)+(($C$2-1)*7)+1,8-WEEKDAY(DATE($A$2,$B$2,1),1)+(($C$2-1)*7)+$D$2))

・マクロ版エクセル関数（日にちだけ返します。）
（単純に回してるだけです。）

Function SarCWeek関数(年, 月, 検索週, 曜日)
　　Dim DCnt As Long, DM As String, DD As String, FCFDM As String
　　Application.Volatile
　　FCFDM = Format(CDate(年 & "/" & 月 + 1 & "/" & 1) - 1, "d")
　　For i = 1 To FCFDM
　　　　bby = Format(CDate(年 & "/" & 月 & "/" & i), "aaa")
　　　　If Format(CDate(年 & "/" & 月 & "/" & i), "aaa") = 曜日 Then
　　　　　 DCnt = DCnt + 1
　　　　　 If 検索週 = DCnt Then
　　　　　　　SarCWeek関数 = i
　　　　　　　Exit Function
　　　　　 End If
　　　　End If
　　Next
　　SarCWeek関数 = CVErr(xlErrValue)
End Function

ＰＳ
春分、秋分の日は、堪忍してください。
地中の自転までの計算はちょっと．．．
独断と偏見で、取合えず目安箱に載せます。

【38】文中間違い訂正。

Jaka - 03/10/29(水) 12:14 -


	引用なし

	パスワード

>３６となってしまいますが、
　↓
３７

>地中の自転までの．．．
地中　→　地球

【59】[管理者削除]

- -


	引用なし

	パスワード

この書き込みは管理者によって削除されました。（06/1/25(水) 18:41）

【88】一応、全部？の祝日です。

Jaka - 05/2/28(月) 11:27 -


	引用なし

	パスワード

B1に西暦年を入れるとその年の祝日がでます。
春分秋分の求め方はわかりません。
また、祝日で固定してはいけないところを固定していたらすみません。

元日　　　　　=DATE($B$1,1,1)
年末年始　　　=DATE($B$1,1,2)
　〃　　　　　=DATE($B$1,1,3)
成人の日　　　=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)
春分日　　　　カレンダーを見て下さい。
みどりの日　　=DATE($B$1,4,29)
憲法記念日　　=DATE($B$1,5,3)
国民の休日　　=DATE($B$1,5,4)
こどもの日　　=DATE($B$1,5,5)
海の日　　　　=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))
秋分の日　　　カレンダーを見て下さい。
体育の日　　　=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)
勤労感謝の日　=DATE($B$1,11,23)
天皇誕生日　　=DATE($B$1,12,23)
年末年始　　　=DATE($B$1,12,31)

【89】Re:一応、全部？の祝日です。

ponpon

- 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】祝日表作成時の振替休日について

Jaka - 06/2/21(火) 13:50 -


	引用なし

	パスワード

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

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

=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】カレンダーコントロールみたなような・・・...

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


	引用なし

	パスワード

２００３年以降からしか考えてないけど、カレンダーコントロールみたいな感じ？

フォーム（UserForm1）
クラス（Class1）
標準モジュール

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

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

フォームモジュール

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 = "ＭＳＰゴシック"
　　　　　　　　.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】標準モジュールのコード

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

【173】７×７マスのカレンダー

Jaka - 06/12/26(火) 10:16 -


	引用なし

	パスワード

全ての月（曜を日含む、7×7マス）の位置を一々決めなければならない手間がありますが、マスの位置をの変則に好き勝手な場所に設定できるようにこんな感じにしてみました。
Ｂ１セルに年号が入っているとします。
年号の不具合チェックはしてません。
祝日、振替休日も入れてません。
土日だけ色を変えました。
一応罫線も入ってます。

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

【182】祝祭日も入れてみた。

Jaka - 07/1/9(火) 9:53 -


	引用なし

	パスワード

ゴミが残っていたので再アップ。

２００６年に決まった？らしい、２００７年から実行される？祝日の変更が、９月の秋分の日、第３月曜が絡むとどうなるのかわからなくて、昨年アップしたものを１度消しましたが、詳しくはやっぱり解りませんでした。（昨年のものとほとんど同じ
改正された新国民の休日が反映されるのは、２００８年の５月からみたいです。（２００９年にも反映されている。）

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

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

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

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

【187】↑の注意点。

Jaka - 07/1/31(水) 10:46 -


	引用なし

	パスワード

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

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

【220】修正点

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】祝日表をまとめてみた。

Jaka - 07/12/6(木) 9:45 -


	引用なし

	パスワード

Ｂ１に西暦年号が入るとして

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

Ｃ４～Ｃ２９
=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")

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

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

=Text(Now,"aaa")

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

【267】表に位置について。

Jaka - 11/2/14(月) 16:59 -


	引用なし

	パスワード

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

Ｂ１
Ｂ４～Ｂ２９
Ｃ４～Ｃ２９

┃ ┃ ┃ ┃ ┃ ┃

24 / 117 ﾂﾘｰ

←次へ　｜　前へ→

ページ：

┃

記事番号：

(SS)C-BOARD v3.8 is Free