【ScreenUpdating = False/True 】を行なっていません。ユーザー側で必ず行って下さい。
また、『kt暦作成』 内では シート の プロテクトチェック を行ない、プロテクト時には作成
しないようになっていますが、ユーザーサイド でも事前に チェック する事をお薦めします。
下記のサンプルコードでは､出力先シートのクリア[ Cells.Clear ]を行なっています。
休日表示に『休日マップ』を使用する場合で､その『休日マップ』が出力先シート上に
用意されていると､シートクリアによって消えてしまいます。クリア前に文字列変数に
保存して「kt暦作成」にはその文字列変数を渡すようにして下さい。
Sub 横サンプル標準()
Dim i As Integer
Dim strADDR As String
Dim dtm基準日 As Date
Dim str基点セル As String
dtm基準日 = DateValue("2001/1/1")
str基点セル = "B2"
If (ActiveSheet.ProtectContents = True) Then
MsgBox "出力先シートがプロテクトされています"
Exit Sub
End If
Application.ScreenUpdating = False
ActiveSheet.Cells.Clear
' 1月目の暦作成後に[基点セル]の位置が[3列の結合セル]になる為､
' 2ヶ月目以降の[Offset計算]が2列分ズレてしまう。
' これを避ける為､結合セルにならない位置を基点セルとして定義し直す。
str基点セル = ActiveSheet.Range(str基点セル).Offset(0, 3).Address(False, False)
For i = 1 To 12
strADDR = ActiveSheet.Range(str基点セル) _
.Offset(5 * (i - 1), -3).Address(False, False)
Call kt暦作成(2, dtm基準日, kt_土日祝, ActiveSheet, strADDR)
dtm基準日 = DateAdd("m", 1, dtm基準日)
Next i
Application.ScreenUpdating = True
End Sub
'-------------------------------『１枠追加』-----------------------------
Sub 横サンプル1枠追加()
Dim dtm基準日 As Date
Dim str基点セル As String
Dim i As Integer
Dim j As Integer
Dim strADDR As String
Dim strADDR2 As String
Dim rng追加枠 As Range
dtm基準日 = DateValue("2001/1/1")
str基点セル = "B2"
If (ActiveSheet.ProtectContents = True) Then
MsgBox "出力先シートがプロテクトされています"
Exit Sub
End If
Application.ScreenUpdating = False
ActiveSheet.Cells.Clear
' 1月目の暦作成後に[基点セル]の位置が[3列の結合セル]になる為､
' 2ヶ月目以降の[Offset計算]が2列分ズレてしまう。
' これを避ける為､結合セルにならない位置を基点セルとして定義し直す。
str基点セル = ActiveSheet.Range(str基点セル).Offset(0, 3).Address(False, False)
For i = 1 To 12
With ActiveSheet
strADDR = .Range(str基点セル) _
.Offset(6 * (i - 1), -3).Address(False, False)
strADDR2 = .Range(strADDR).Offset(4, 0).Address(False, False)
Set rng追加枠 = .Range(.Range(strADDR2), _
.Range(strADDR2).Offset(0, 30))
End With
Call kt暦作成(2, dtm基準日, kt_土日祝, ActiveSheet, strADDR)
' 『追加した枠内の書式設定』
With rng追加枠
.Rows(1).RowHeight = 21
.Font.Name = "ＭＳ Ｐ明朝"
.Font.Size = 11
With .Borders
.Item(xlEdgeTop).LineStyle = xlNone ' 一旦２重線を削除
.Item(xlEdgeTop).LineStyle = xlContinuous
.Item(xlEdgeBottom).LineStyle = xlDouble
.Item(xlEdgeRight).LineStyle = xlDouble
.Item(xlEdgeLeft).LineStyle = xlDouble
.Item(xlInsideVertical).LineStyle = xlContinuous
End With
For j = 1 To 31
With .Cells(1, j)
.Interior.Color = .Offset(-1, 0).Interior.Color ' 休日表示のコピー
End With
Next j
End With
dtm基準日 = DateAdd("m", 1, dtm基準日)
Next i
Set rng追加枠 = Nothing
Application.ScreenUpdating = True
End Sub
'-------------------------------『２枠追加』-----------------------------
Sub 横サンプル2枠追加()
Dim dtm基準日 As Date
Dim str基点セル As String
Dim i As Integer
Dim j As Integer
Dim strADDR As String
Dim strADDR2 As String
Dim rng追加枠 As Range
dtm基準日 = DateValue("2001/1/1")
str基点セル = "B2"
If (ActiveSheet.ProtectContents = True) Then
MsgBox "出力先シートがプロテクトされています"
Exit Sub
End If
Application.ScreenUpdating = False
ActiveSheet.Cells.Clear
' 1月目の暦作成後に[基点セル]の位置が[3列の結合セル]になる為､
' 2ヶ月目以降の[Offset計算]が2列分ズレてしまう。
' これを避ける為､結合セルにならない位置を基点セルとして定義し直す。
str基点セル = ActiveSheet.Range(str基点セル).Offset(0, 3).Address(False, False)
For i = 1 To 12
With ActiveSheet
strADDR = .Range(str基点セル) _
.Offset(7 * (i - 1), -3).Address(False, False)
strADDR2 = .Range(strADDR).Offset(4, 0).Address(False, False)
Set rng追加枠 = .Range(.Range(strADDR2), _
.Range(strADDR2).Offset(1, 30))
End With
Call kt暦作成(2, dtm基準日, kt_土日祝, ActiveSheet, strADDR)
' 『追加した枠内の書式設定』
With rng追加枠
.Rows(1).RowHeight = 21
.Rows(2).RowHeight = 21
.Font.Name = "ＭＳ Ｐ明朝"
.Font.Size = 11
With .Borders
.Item(xlEdgeTop).LineStyle = xlNone ' 一旦２重線を削除
.Item(xlEdgeTop).LineStyle = xlContinuous
.Item(xlEdgeBottom).LineStyle = xlDouble
.Item(xlEdgeRight).LineStyle = xlDouble
.Item(xlEdgeLeft).LineStyle = xlDouble
.Item(xlInsideHorizontal).LineStyle = xlContinuous
.Item(xlInsideVertical).LineStyle = xlContinuous
End With
For j = 1 To 31
With .Cells(1, j)
.Interior.Color = .Offset(-1, 0).Interior.Color ' 休日表示のコピー
.Offset(1, 0).Interior.Color = .Offset(-1, 0).Interior.Color
End With
Next j
End With
dtm基準日 = DateAdd("m", 1, dtm基準日)
Next i
Set rng追加枠 = Nothing
Application.ScreenUpdating = True
End Sub
