| For i = 1 To 12 と For j = 1 To 32 の2重ループにしていますが、
これは月ごとに行を変えているためです。
1行で良いのなら、開始日から終了日までのループだけで済みます。
以下のように書き換えてみました。
Sub calendar_make4()
'カレンダー作成
'
Dim sh1 As Worksheet
Dim i As Integer, j As Integer
Dim myDay As Date
Dim myPs As Range
Dim Holiday As Range
Dim iCol As Variant, fCol As Variant
Dim myFlg As Boolean
Dim sYear As Integer, eYear As Integer
Dim sMonth As Integer, eMonth As Integer
Dim sDay As Integer, eDay As Integer
Dim gyokan As Long, mycnt As Long
Dim cnt As Long
Set sh1 = Worksheets("カレンダー4")
Set Holiday = Worksheets("祝日").Range("A1:A84")
Application.ScreenUpdating = False
gyokan = 4 '行間隔
With sh1
'着色クリア
With .Range("D4:BZ8") '適切な範囲にすること
.ClearContents
.Interior.ColorIndex = xlNone
.Font.ColorIndex = 0
End With
'設定年月日
sYear = Year(.Range("E2").Value)
sMonth = Month(.Range("E2").Value)
sDay = Day(.Range("E2").Value)
eYear = Year(.Range("E3").Value)
eMonth = Month(.Range("E3").Value)
eDay = Day(.Range("E3").Value)
i = 1
For j = 1 To .Range("E3").Value - .Range("E2").Value + 1
'入力する日付
myDay = DateSerial(sYear, sMonth, sDay + cnt)
cnt = cnt + 1
'月、日にちを入力
.Cells(2 + gyokan * i, 4).Value = Month(.Cells(2 + gyokan * i, 5).Value) & "月"
.Cells(2 + gyokan * i + 1, 4).Value = "曜日"
' Set myPs = .Cells(2 + gyokan * i, 4 + j) '入力するセル ここを基準に設定しています
Set myPs = .Cells(2 + gyokan, 4 + j) '入力するセル ここを基準に設定しています
myPs.Value = myDay
myPs.NumberFormatLocal = "d" '表示形式を"d"に設定しています。
'曜日を入力
myPs.Offset(1, 0).Value = Format(myDay, "aaa")
'土日check
myFlg = False
Select Case myPs.Offset(1, 0).Value
Case "土"
iCol = 34 '塗りつぶしの色番号
fCol = 5 'フォントの色番号
myFlg = True
Case "日"
iCol = 36
fCol = 3
myFlg = True
End Select
'祝日check
If WorksheetFunction.CountIf(Holiday, myPs.Value) = 1 Then
iCol = 40
fCol = 3
myFlg = True
End If
'着色 土日祝日の時(myFlg = True)に実行
If myFlg = True Then
.Range(myPs, myPs.Offset(1, 0)).Interior.ColorIndex = iCol
.Range(myPs, myPs.Offset(1, 0)).Font.ColorIndex = fCol
End If
Next j
End With
Application.ScreenUpdating = True
End Sub
|