■13363 / 1階層) |
指定年月日からの横型の年間カレンダーを作成するの件
|
□投稿者/ よねさん -(2019/03/15(Fri) 08:52:09)
| 横型のカレンダーを縦型に変更してみました。
ほとんど同じです。行が列に変更されていますので、その部分を注意してみていただければよろしいかと思います。
カレンダーを作成するシートは カレンダー2
祝祭日の一覧は 「祝日」シートのA1セルから縦に入力します。
E2セルには 2019/1/1
E3セルには =DATE(YEAR(E2)+1,MONTH(E2),DAY(E2)-1)
O1セルには =TEXT(E3,"ggge")& "年度 カレンダー"
と入力しています。
コードの変更箇所は
Dim retukan As Long, mycnt As Long
retukan = 4 '列間隔
ここから----
'月、日にちを入力
.Cells(6, retukan * i).Value = Month(.Cells(2, 5).Value) + i - 1 & "月"
.Cells(6, retukan * i + 1).Value = "曜日"
Set myPs = .Cells(6 + j, retukan * i) '入力するセル ここを基準に設定しています
ここまで----
Offset(1,0)の箇所を↓のように Offset(0, 1) と数カ所を変更しています。
myPs.Offset(0, 1).Value = Format(myDay, "aaa")
といったところです。
Sub calendar_tate()
'カレンダー作成
'
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 retukan As Long, mycnt As Long
Set sh1 = Worksheets("カレンダー2")
Set Holiday = Worksheets("祝日").Range("A1:A84")
Application.ScreenUpdating = False
retukan = 4 '列間隔
With sh1
'着色クリア
With .Range("D4:AW100") 'とりあえず100行目までを設定範囲として考えています。
.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)
For i = 1 To 12
For j = 1 To 32
'入力する日付
myDay = DateSerial(sYear, sMonth - 1 + i, sDay - 1 + j)
'ループを抜ける条件
If Day(myDay) = sDay Then
mycnt = mycnt + 1
If mycnt = 2 Then
mycnt = 0
Exit For
End If
End If
'終了日になったら終了する
If myDay > DateSerial(eYear, eMonth, eDay) Then
Application.ScreenUpdating = True
End
End If
'月、日にちを入力
.Cells(6, retukan * i).Value = Month(.Cells(2, 5).Value) + i - 1 & "月"
.Cells(6, retukan * i + 1).Value = "曜日"
Set myPs = .Cells(6 + j, retukan * i) '入力するセル ここを基準に設定しています
myPs.Value = myDay
myPs.NumberFormatLocal = "d" '表示形式を"d"に設定しています。
'曜日を入力
myPs.Offset(0, 1).Value = Format(myDay, "aaa")
'土日check
myFlg = False
Select Case myPs.Offset(0, 1).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(0, 1)).Interior.ColorIndex = iCol
.Range(myPs, myPs.Offset(0, 1)).Font.ColorIndex = fCol
End If
Next j
Next i
End With
Application.ScreenUpdating = True
End Sub
|
|