このコードを検証するための前提作業と前回の振り返りと今回の追加についてご説明させて頂きたいと思います。
１．前提作業
まずは「サーバー管理台帳」と「実機環境作業手続き申請書」が必要となります。
①サーバー管理台帳のファイル：
見出しの行が3行目となり、データ情報は「4行目」から「41行目」までとなります。
ファイルの保存の前に「2025/12/20」の日付でフィルタをかけておいてください。
②実機環境作業手続き申請書のファイル：
基本的には「改訂履歴」(１番目)はシートだけを用意しておいてもらえればよいのですが、コードを検証して頂くには「作業手続き申請書」(２番目)のシートが存在した状態で正しい列の状態に揃えてもらわないと正しい動作にはならないのでご注意ください。
２．前回の作業について
追加した行に参照元ファイルから取得したデータを追記していく処理を追加しました。
３．今回の追加点と修正点について
「改訂履歴」のシートに日付を追記することと「作業手続き申請書」の作業実施日/開始時間と「作業実施日/終了時間」日付の出力の表記を変更致しました。
＜サーバー管理台帳＞
＜実機環境作業手続き申請書＞
'========================================================================
' 変数の設定
'========================================================================
Dim basePath, srcPath, outPath
Dim xlApp, srcBook, srcSheet, outBook, outSheet
Dim rawText, onlyNum, ch, idx
Dim targetDate, dataStartRow, lastRow, outRow, r, hitcount
Dim targetText, i
Dim startCopyRow, pasteRow, copyRange, pasteRange, j, arr(5)
'========================================================================
' 参照元と出力先のファイルの指定してファイルを開く
'========================================================================
basePath = "C:\Users\sasio-tech.SASIO.JP\Documents\作業申請ツール"
srcPath = basePath & "\sample_001.xlsx"
outPath = basePath & "\sample_002.xlsx"
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = False
xlApp.DisplayAlerts = False
Set srcBook = xlApp.Workbooks.Open(srcPath)
Set srcSheet = srcBook.Sheets(1)
Set outBook = xlApp.Workbooks.Open(outPath)
'========================================================================
' 流用できる情報
'========================================================================
Dim setDateStr
setDateStr = "2025/12/01" ' ← 文字列として保持
'========================================================================
' 改定履歴の処理
'========================================================================
Set outSheet = outBook.Sheets(1)
' 4行目・2列目（B4）に文字列をセット
outSheet.Cells(4, 2).Value = setDateStr
outSheet.Cells(4, 4).Value = setDateStr
outSheet.Cells(4, 6).Value = setDateStr
'========================================================================
'「作業手続き申請書」(シート名)でオートフィルタの設定を確認する
'========================================================================
'「作業手続き申請書」(シート名)を指定する
Set outSheet = outBook.Sheets(2)
Const xlCellTypeVisible = 12
Const xlUp = -4162
' サンプルコードのための動作確認のため日付を「2025/12/25」を固定化
targetDate = "2025/12/20"
dataStartRow = 4
If srcSheet.AutoFilterMode = False Then
MsgBox "オートフィルタが設定されていません。"
srcBook.Close False
outBook.Close False
xlApp.Quit
WScript.Quit
End If
srcSheet.Range("A4").AutoFilter 7, "*" & targetDate & "*"
On Error Resume Next
srcSheet.Range("G4:G41").SpecialCells xlCellTypeVisible
If Err.Number <> 0 Then
MsgBox "対象日付のデータがありません。"
Err.Clear
srcBook.Close False
outBook.Close False
xlApp.Quit
WScript.Quit
End If
On Error GoTo 0
lastRow = srcSheet.Cells(srcSheet.Rows.Count, "G").End(xlUp).Row
'========================================================================
' 参照元ファイルのC列から出力先ファイルのH列に出力する処理
'========================================================================
hitcount = 0
outRow = 28
For r = dataStartRow To lastRow
If srcSheet.Rows(r).Hidden = False Then
If Trim(srcSheet.Cells(r, "G").Value) <> "" Then
'H列にサーバー管理番号を出力
outSheet.Cells(outRow, "H").Value = srcSheet.Cells(r, "C").Value
'M列にサーバー名を出力
outSheet.Cells(outRow, "M").Value = srcSheet.Cells(r, "C").Value
' R結合セルの書式を「数値」にする（VBScript）
With outSheet.Cells(outRow, "R")
If .MergeCells = True Then
.NumberFormat = "0"
End If
End With
'X列に「作業実施日/開始時間」を出力
rawText = CStr(srcSheet.Cells(r, "G").Value)
onlyNum = ""
For idx = 1 To Len(rawText)
ch = Mid(rawText, idx, 1)
If ch >= "0" And ch <= "9" Then
onlyNum = onlyNum & ch
End If
Next
' YYYYMMDD の先頭8桁だけ使用
outSheet.Cells(outRow, "R").Value = Left(onlyNum, 8)
outSheet.Cells(outRow+1, "R").Value = "9時00分"
outRow = outRow + 2
hitcount = hitcount + 1
End If
End If
Next
'========================================================================
' 参照元ファイルのD列から出力先ファイルのH列に出力処理（C列の続き）
'========================================================================
For r = dataStartRow To lastRow
If srcSheet.Rows(r).Hidden = False Then
If Trim(srcSheet.Cells(r, "G").Value) <> "" Then
'H列にサーバー管理番号を出力
outSheet.Cells(outRow, "H").Value = srcSheet.Cells(r, "D").Value
'M列にサーバー名を出力
outSheet.Cells(outRow, "M").Value = srcSheet.Cells(r, "D").Value
' R結合セルの書式を「数値」にする（VBScript）
With outSheet.Cells(outRow, "X")
If .MergeCells = True Then
.NumberFormat = "0"
End If
End With
'X列に「作業実施日/終了時間」を出力
rawText = CStr(srcSheet.Cells(r, "G").Value)
onlyNum = ""
For idx = 1 To Len(rawText)
ch = Mid(rawText, idx, 1)
If ch >= "0" And ch <= "9" Then
onlyNum = onlyNum & ch
End If
Next
' YYYYMMDD の先頭8桁だけ使用
outSheet.Cells(outRow, "X").Value = Left(onlyNum, 8)
outSheet.Cells(outRow+1, "X").Value = "15時00分"
outRow = outRow + 2
hitcount = hitcount + 1
End If
End If
Next
MsgBox "対象日付 " & targetDate & " は " & hitcount & " 件です。"
'========================================================================
' コピーして挿入する行の処理
'========================================================================
targetText = "１．現在設定されている監視対象となっている"
lastRow = outSheet.Cells(outSheet.Rows.Count, "D").End(xlUp).Row
For r = 83 To lastRow
If InStr(outSheet.Cells(r, "D").Value, targetText) > 0 Then
startCopyRow = r
Exit For
End If
Next
hitcount = hitcount / 2 ' 整数除算（小数切り捨て）
For i = 1 To 7
Select Case i
Case 1
startCopyRow = startCopyRow + 2
MsgBox "挿入する行" & hitcount & "行分です"
MsgBox "最初の行の挿入開始位置は" & startCopyRow & "行目です"
arr(i-1) = startCopyRow
Case 2
startCopyRow = startCopyRow + pasteRow + 8
MsgBox "次の行の挿入開始位置は" & startCopyRow & "行目です"
arr(i-1) = startCopyRow
Case 3
startCopyRow = startCopyRow + 4
MsgBox "次の行の挿入開始位置は" & startCopyRow & "行目です"
arr(i-1) = startCopyRow
Case 5
startCopyRow = startCopyRow + 10
MsgBox "次の行の挿入開始位置は" & startCopyRow & "行目です"
arr(i-2) = startCopyRow
Case 6
startCopyRow = startCopyRow + 8
MsgBox "次の行の挿入開始位置は" & startCopyRow & "行目です"
arr(i-2) = startCopyRow
Case 7
startCopyRow = startCopyRow + 4
MsgBox "次の行の挿入開始位置は" & startCopyRow & "行目です"
arr(i-2) = startCopyRow
Case Else
startCopyRow = startCopyRow - pasteRow
MsgBox "次は切戻しの場合の設定値の行に移動します"
End Select
If i <> 4 Then
For j = 1 To hitcount - 1
outSheet.Rows(startCopyRow).Insert
startCopyRow = startCopyRow + 1
Next
MsgBox "最終行" & startCopyRow & "行です"
End If
Next
'========================================================================
' 取得データを出力
'========================================================================
For i = 1 To 7
Select Case i
Case 1
startCopyRow = arr(i-1)
MsgBox "最初の行の追記の開始位置は" & startCopyRow & "行目です"
For r = dataStartRow To lastRow
If srcSheet.Rows(r).Hidden = False Then
If Trim(srcSheet.Cells(r, "G").Value) <> "" Then
outSheet.Cells(startCopyRow, "E").Value = "□"
outSheet.Cells(startCopyRow, "F").Value = srcSheet.Cells(r, "C").Value
outSheet.Cells(startCopyRow, "K").Value = srcSheet.Cells(r, "C").Value
startCopyRow = startCopyRow + 1
hitcount = hitcount + 1
End If
End If
Next
Case 2
startCopyRow = arr(i-1)
MsgBox "最初の行の追記の開始位置は" & startCopyRow & "行目です"
For r = dataStartRow To lastRow
If srcSheet.Rows(r).Hidden = False Then
If Trim(srcSheet.Cells(r, "G").Value) <> "" Then
outSheet.Cells(startCopyRow, "E").Value = "□"
outSheet.Cells(startCopyRow, "F").Value = srcSheet.Cells(r, "D").Value
outSheet.Cells(startCopyRow, "K").Value = srcSheet.Cells(r, "D").Value
startCopyRow = startCopyRow + 1
hitcount = hitcount + 1
End If
End If
Next
Case 3
startCopyRow = arr(i-1)
MsgBox "最初の行の追記の開始位置は" & startCopyRow & "行目です"
For r = dataStartRow To lastRow
If srcSheet.Rows(r).Hidden = False Then
If Trim(srcSheet.Cells(r, "G").Value) <> "" Then
outSheet.Cells(startCopyRow, "E").Value = "□"
outSheet.Cells(startCopyRow, "F").Value = srcSheet.Cells(r, "D").Value
outSheet.Cells(startCopyRow, "K").Value = srcSheet.Cells(r, "D").Value
startCopyRow = startCopyRow + 1
hitcount = hitcount + 1
End If
End If
Next
Case 5
startCopyRow = arr(i-2)
MsgBox "最初の行の追記の開始位置は" & startCopyRow & "行目です"
For r = dataStartRow To lastRow
If srcSheet.Rows(r).Hidden = False Then
If Trim(srcSheet.Cells(r, "G").Value) <> "" Then
outSheet.Cells(startCopyRow, "E").Value = "□"
outSheet.Cells(startCopyRow, "F").Value = srcSheet.Cells(r, "D").Value
outSheet.Cells(startCopyRow, "K").Value = srcSheet.Cells(r, "D").Value
startCopyRow = startCopyRow + 1
hitcount = hitcount + 1
End If
End If
Next
Case 6
startCopyRow = arr(i-2)
MsgBox "最初の行の追記の開始位置は" & startCopyRow & "行目です"
For r = dataStartRow To lastRow
If srcSheet.Rows(r).Hidden = False Then
If Trim(srcSheet.Cells(r, "G").Value) <> "" Then
outSheet.Cells(startCopyRow, "E").Value = "□"
outSheet.Cells(startCopyRow, "F").Value = srcSheet.Cells(r, "C").Value
outSheet.Cells(startCopyRow, "K").Value = srcSheet.Cells(r, "C").Value
startCopyRow = startCopyRow + 1
hitcount = hitcount + 1
End If
End If
Next
Case 7
startCopyRow = arr(i-2)
MsgBox "最初の行の追記の開始位置は" & startCopyRow & "行目です"
For r = dataStartRow To lastRow
If srcSheet.Rows(r).Hidden = False Then
If Trim(srcSheet.Cells(r, "G").Value) <> "" Then
outSheet.Cells(startCopyRow, "E").Value = "□"
outSheet.Cells(startCopyRow, "F").Value = srcSheet.Cells(r, "C").Value
outSheet.Cells(startCopyRow, "K").Value = srcSheet.Cells(r, "C").Value
startCopyRow = startCopyRow + 1
hitcount = hitcount + 1
End If
End If
Next
End Select
Next
srcBook.Close False
outBook.Save
outBook.Close
xlApp.Quit
