Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

45590 / 76735

←次へ　｜　前へ→


	【36135】使う上司の都合なんて知りませんが...。

Jaka - 06/3/22(水) 9:34 -


	引用なし

	パスワード

こんな感じでもいいんじゃないか、って言う手法です。
上から書いているので、レイアウトなどは全然違いますよ。

Sub karen2()
Dim Dday As String, Nen As Integer, Tuk As Integer, Resz As Integer
Dim kyusai As Variant, StrtRag As String, STRow As Long
StrtRag = "A2:B2"
Range(StrtRag).Resize(31).Clear
Nen = 2006 'Range("A1").Value
Tuk = 3　　'Range("B1").Value
Dday = Format(DateSerial(Nen, Tuk, 1), "yyyy/m/d")
Range(StrtRag).Cells(1).Value = Dday
Range(StrtRag).Cells(2).Value = Format(Dday, "aaa")
Resz = Format(DateSerial(Nen, Tuk + 1, 1) - 1, "d")
'Application.ScreenUpdating = False
With Range(StrtRag)
　　.AutoFill Destination:=.Resize(7), Type:=xlFillDefault
End With
STRow = Range(StrtRag).Row
For i = STRow To STRow + 6
　　With Cells(i, 1)
　　　 If WeekDay(.Value) = "7" Then
　　　　　.Resize(, 2).Interior.ColorIndex = 8
　　　 ElseIf WeekDay(.Value) = "1" Then
　　　　　.Resize(, 2).Interior.ColorIndex = 7
　　　 End If
　　End With
Next
With Range(StrtRag).Resize(7)
　　.AutoFill Destination:=.Resize(Resz), Type:=xlFillDefault
End With
罫線

If MsgBox("祝日、振替も入れる？", vbYesNo + vbQuestion + vbDefaultButton1) = vbNo Then Exit Sub
kyusai = HolidayTBL2(Nen)
For i = STRow To Resz + 1
　　With Cells(i, 1)
　　　　Mct = Application.Match(Format(.Value, "yyyy/m/d"), kyusai, 0)
　　　　If Not (IsError(Mct)) Then
　　　　　 .Resize(, 2).Interior.ColorIndex = 7
　　　　End If
　　End With
Next
'Application.ScreenUpdating = True
End Sub

Private Function HolidayTBL2(ByVal SachYear As Long) As Variant
　 Dim FixHoliday As Variant, WekDy As Long, SVSt As String
　 Dim CagJan As Long, CagJul As Long, CagSep As Long, TBC As Long
　 Dim Equx39 As Long, TBL() As Variant, SacWek As Long
　 Dim i As Long, ii As Long

　 FixHoliday = Array("1/1", "2/11", "4/29", "5/3", "5/4", "5/5", _
　　　　　　　　　　　"11/3", "11/23", "12/23")
　 TBC = -1
　 For i = 0 To UBound(FixHoliday)
　　　 If WeekDay(SachYear & "/" & FixHoliday(i)) <> 1 Then
　　　　　TBC = TBC + 1
　　　　　ReDim Preserve TBL(TBC)
　　　　　TBL(UBound(TBL)) = SachYear & "/" & FixHoliday(i)
　　　 ElseIf Not (Right(FixHoliday(i), 3) = "5/3" Or Right(FixHoliday(i), 3) = "5/4") Then
　　　　　If WeekDay(SachYear & "/" & FixHoliday(i)) = 1 Then
　　　　　　 TBC = TBC + 1
　　　　　　 ReDim Preserve TBL(TBC)
　　　　　　 TBL(UBound(TBL)) = Format(CDate(SachYear & "/" & FixHoliday(i)) + 1, "yyyy/m/d")
　　　　　End If
　　　 End If
　 Next
　
　 WekDy = WeekDay(SachYear & "/1/1", vbSunday)
　 SacWek = 2
　 If WekDy <= 2 Then
　　　CagJan = 2 - WekDy + ((SacWek - 1) * 7) + 1
　 Else
　　　CagJan = 8 - WekDy + ((SacWek - 1) * 7) + 2
　 End If
　 ReDim Preserve TBL(UBound(TBL) + 1)
　 TBL(UBound(TBL)) = SachYear & "/1/" & CagJan

　 WekDy = WeekDay(SachYear & "/7/1", vbSunday)
　 SacWek = 3
　 If WekDy <= 2 Then
　　　CagJul = 2 - WekDy + ((SacWek - 1) * 7) + 1
　 Else
　　　CagJul = 8 - WekDy + ((SacWek - 1) * 7) + 2
　 End If
　 ReDim Preserve TBL(UBound(TBL) + 1)
　 TBL(UBound(TBL)) = SachYear & "/7/" & CagJul

　 WekDy = WeekDay(SachYear & "/9/1", vbSunday)
　 SacWek = 3
　 If WekDy <= 2 Then
　　　CagSep = 2 - WekDy + ((SacWek - 1) * 7) + 1
　 Else
　　　CagSep = 8 - WekDy + ((SacWek - 1) * 7) + 2
　 End If
　 ReDim Preserve TBL(UBound(TBL) + 1)
　 TBL(UBound(TBL)) = SachYear & "/9/" & CagSep

　 WekDy = WeekDay(SachYear & "/10/1", vbSunday)
　 SacWek = 2
　 If WekDy <= 2 Then
　　　CagOct = 2 - WekDy + ((SacWek - 1) * 7) + 1
　 Else
　　　CagOct = 8 - WekDy + ((SacWek - 1) * 7) + 2
　 End If
　 ReDim Preserve TBL(UBound(TBL) + 1)
　 TBL(UBound(TBL)) = SachYear & "/10/" & CagOct

　 Equx39 = Fix(20.8431 + 0.242194 * _
　　　　　　(SachYear - 1980) - Fix((SachYear - 1980) / 4))
　 ReDim Preserve TBL(UBound(TBL) + 1)
　 TBL(UBound(TBL)) = SachYear & "/3/" & Equx39
　
　 If WeekDay(TBL(UBound(TBL))) = 1 Then
　　　TBL(UBound(TBL)) = Format(CDate(TBL(UBound(TBL))) + 1, "yyyy/m/d")
　 End If

　 Equx39 = Fix(23.2488 + 0.242194 * _
　　　　　　(SachYear - 1980) - Fix((SachYear - 1980) / 4))
　 ReDim Preserve TBL(UBound(TBL) + 1)
　 TBL(UBound(TBL)) = SachYear & "/9/" & Equx39

　 If WeekDay(TBL(UBound(TBL))) = 1 Then
　　　TBL(UBound(TBL)) = Format(CDate(TBL(UBound(TBL))) + 1, "yyyy/m/d")
　 End If

　 If WeekDay(DateValue(SachYear & "/9/" & Equx39), vbSunday) = 4 Then
　　　ReDim Preserve TBL(UBound(TBL) + 1)
　　　TBL(UBound(TBL)) = SachYear & "/9/" & Equx39 - 1
　 End If
　
　 HolidayTBL2 = TBL
　 Erase FixHoliday, TBL
　 DoEvents
End Function

Sub 罫線()
　　With Range("A2:B2").Resize(31)
　　　　.Borders(xlEdgeLeft).Weight = xlThin
　　　　.Borders(xlEdgeTop).Weight = xlThin
　　　　.Borders(xlEdgeBottom).Weight = xlThin
　　　　.Borders(xlEdgeRight).Weight = xlThin
　　　　.Borders(xlInsideVertical).Weight = xlThin
　　　　.Borders(xlInsideHorizontal).Weight = xlHairline
　　End With
End Sub

0 hits

▼

【36019】コード簡略化のアドバイスを 春まき 06/3/19(日) 4:45