''' <summary>
''' 処理名:createTestTemplate
''' 概要:指定シートにテスト結果記録用のテンプレート行を指定件数分作成する。
''' 4行目以降のセルと画像を全クリアした後、2~3行目を指定間隔でコピーする。
''' </summary>
Sub createTestTemplate()
Dim lngCount As Long
Dim lngIdx As Long
Dim lngDstRow As Long
Dim lngLastRow As Long
Dim lngBlockSize As Long
Dim shpObj As Shape
Dim strInput As String
Dim wstTarget As Worksheet
Const C_ROW_INTERVAL As Long = 42
Const C_SRC_START As Long = 2
Const C_SRC_END As Long = 3
Const C_SHEET_NAME As String = "Sheet1"
On Error Resume Next
Set wstTarget = ThisWorkbook.Worksheets(C_SHEET_NAME)
On Error GoTo 0
If wstTarget Is Nothing Then
MsgBox "シート「" & C_SHEET_NAME & "」が見つかりません。", vbExclamation
Exit Sub
End If
strInput = InputBox("項目数を入力してください。", "テンプレート作成")
If strInput = "" Then
Exit Sub
End If
If Not IsNumeric(strInput) Then
MsgBox "数値を入力してください。", vbExclamation
Exit Sub
End If
lngCount = CLng(strInput)
If lngCount < 1 Then
MsgBox "1以上の数値を入力してください。", vbExclamation
Exit Sub
End If
'テンプレート行数 + 空き行数
lngBlockSize = (C_SRC_END - C_SRC_START + 1) + C_ROW_INTERVAL
Application.ScreenUpdating = False
With wstTarget
'既存の画像を全削除
For Each shpObj In .Shapes
shpObj.Delete
Next shpObj
'4行目以降を全クリア
lngLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
If lngLastRow >= 4 Then
.Rows("4:" & lngLastRow).Clear
End If
'1件目のNo.にROW関数を設定
.Cells(C_SRC_START, 2).Formula = "=(ROW()-" & C_SRC_START & ")/" & lngBlockSize & "+1"
'2件目以降をコピー
For lngIdx = 1 To lngCount - 1
lngDstRow = C_SRC_START + (lngBlockSize * lngIdx)
.Rows(C_SRC_START & ":" & C_SRC_END).Copy Destination:=.Rows(lngDstRow)
Next lngIdx
End With
Application.ScreenUpdating = True
MsgBox lngCount & "件分のテンプレートを作成しました。", vbInformation
End Sub