| |
こんな感じでもいいんじゃないか、って言う手法です。
上から書いているので、レイアウトなどは全然違いますよ。
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
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
- 06/3/20(月) 13:06 -
