【Excel VBA】画像＋テキストで作る検索可能なマニュアル作成ツールのご紹介（動画マニュアルの弱点を補完）

女性

操作マニュアルを効率よく作成するにはどうすればいいですか。

動画は映像・音声付きで分かり易いですが、分からない部分だけ見直したりするのは該当箇所を探すのが手間だったりしますね。

HUNT

女性2

そうなんです。難しいですよね。。
分かり易さと探しやすさの両方があればいいのですが。。

動画マニュアルに加えて、VBAで画像とテキストを取り込むExcelマニュアルを作成すればできますよ。

HUNT

本記事でご紹介すること

動画マニュアルのメリットと弱点について説明します
画像＋テキストマニュアルがなぜ業務で役立つのかを解説します
マニュアル作成を自動化するVBAの全体像をご紹介します
実際に使えるVBAコード（3ステップ構成）を掲載します

実行手順

本VBAは、マニュアル作成を3工程で自動化します。

工程1：マニュアルの土台を作成

新規Excelブックを作成します
見出し行を自動生成し、最大10001行分の枠を用意します
名前を付けて保存し、一旦ブックを閉じます

工程2：テキストマニュアルの取り込み

UTF-8対応のテキストファイルを読み込みます
「◇」区切りで1手順＝10行として自動配置します
10行を超える説明文は10行目に集約します

工程3：画像の取り込み

複数の画像ファイルを一括選択します
ファイル名順に並び替えて自動挿入します
1手順ごとに画像を配置し、サイズも自動調整します

コード

以下が、実際に使用できる マニュアル作成用VBA（画像・テキスト取り込み対応） です。
※そのまま標準モジュールに貼り付けて使用できます。

モジュール1

Sub Step1_CreateNewBook_ForceSaveAndClose()
    Dim newBook As Workbook
    Dim ws As Worksheet
    Dim i As Long
    Dim counter As Integer: counter = 1
    Dim saveFileName As Variant

    ' 1. 開始確認
    If MsgBox("【工程1：新規ブック作成】を開始します。" & vbCrLf & _
              "マニュアルの土台（最大10001行）を作成し、名前を付けて保存後に一旦閉じます。" & vbCrLf & vbCrLf & _
              "よろしいですか？", vbQuestion + vbYesNo, "工程1の確認") = vbNo Then Exit Sub

    ' 2. 新規ブック作成と初期設定
    Set newBook = Workbooks.Add
    Set ws = newBook.Worksheets(1)
    ws.Name = "手順"

    ' 描画停止（処理高速化）
    Application.ScreenUpdating = False
    
    With ws
        .Cells.Font.Name = "Meiryo UI"
        .Cells.Font.Size = 11
        .Cells.Font.Bold = True
        
        ' ★修正箇所：ループの終端を 10001 に変更
        ' 見出し行（水色）と連番の作成
        For i = 1 To 10001 Step 10
            .Rows(i).Interior.Color = RGB(0, 255, 255)
            .Cells(i, 1).Value = counter
            counter = counter + 1
        Next i
        
        ' 書式設定
        With .Columns("A:G")
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
        End With
        .Columns("A").AutoFit
        .Columns("H").ColumnWidth = 60
        .Columns("H").WrapText = True
        .Columns("H").VerticalAlignment = xlTop
    End With
    
    Application.ScreenUpdating = True

    ' 3. 名前を付けて保存の実行
    MsgBox "マニュアルの土台（10001行分）が完成しました。" & vbCrLf & _
           "保存先を指定してください。保存後、このブックは自動で閉じられます。", vbInformation, "保存のお願い"

    saveFileName = Application.GetSaveAsFilename( _
        InitialFileName:="操作手順書.xlsx", _
        FileFilter:="Excelブック (*.xlsx), *.xlsx", _
        Title:="【工程1】作成したマニュアルを保存してください")

    ' 4. 保存と終了処理
    If saveFileName <> False Then
        newBook.SaveAs fileName:=saveFileName, FileFormat:=xlOpenXMLWorkbook
        
        ' 保存したブックを閉じる
        newBook.Close SaveChanges:=False
        
        MsgBox "保存してブックを閉じました。" & vbCrLf & vbCrLf & _
               "【次のステップ】" & vbCrLf & _
               "「工程2：テキスト取り込み」を実行してください。", vbInformation, "工程1完了"
    Else
        ' 保存がキャンセルされた場合
        MsgBox "保存がキャンセルされたため、作成したブックを破棄して終了します。", vbExclamation, "処理中断"
        newBook.Close SaveChanges:=False
    End If
End Sub

Sub Step1_CreateNewBook_ForceSaveAndClose()

Dim newBook As Workbook

Dim ws As Worksheet

Dim i As Long

Dim counter As Integer: counter = 1

Dim saveFileName As Variant

' 1. 開始確認

If MsgBox("【工程1：新規ブック作成】を開始します。" & vbCrLf & _

"マニュアルの土台（最大10001行）を作成し、名前を付けて保存後に一旦閉じます。" & vbCrLf & vbCrLf & _

"よろしいですか？", vbQuestion + vbYesNo, "工程1の確認") = vbNo Then Exit Sub

' 2. 新規ブック作成と初期設定

Set newBook = Workbooks.Add

Set ws = newBook.Worksheets(1)

ws.Name = "手順"

' 描画停止（処理高速化）

Application.ScreenUpdating = False

With ws

.Cells.Font.Name = "Meiryo UI"

.Cells.Font.Size = 11

.Cells.Font.Bold = True

' ★修正箇所：ループの終端を 10001 に変更

' 見出し行（水色）と連番の作成

For i = 1 To 10001 Step 10

.Rows(i).Interior.Color = RGB(0, 255, 255)

.Cells(i, 1).Value = counter

counter = counter + 1

Next i

' 書式設定

With .Columns("A:G")

.HorizontalAlignment = xlCenter

.VerticalAlignment = xlCenter

End With

.Columns("A").AutoFit

.Columns("H").ColumnWidth = 60

.Columns("H").WrapText = True

.Columns("H").VerticalAlignment = xlTop

End With

Application.ScreenUpdating = True

' 3. 名前を付けて保存の実行

MsgBox "マニュアルの土台（10001行分）が完成しました。" & vbCrLf & _

"保存先を指定してください。保存後、このブックは自動で閉じられます。", vbInformation, "保存のお願い"

saveFileName = Application.GetSaveAsFilename( _

InitialFileName:="操作手順書.xlsx", _

FileFilter:="Excelブック (*.xlsx), *.xlsx", _

Title:="【工程1】作成したマニュアルを保存してください")

' 4. 保存と終了処理

If saveFileName <> False Then

newBook.SaveAs fileName:=saveFileName, FileFormat:=xlOpenXMLWorkbook

' 保存したブックを閉じる

newBook.Close SaveChanges:=False

MsgBox "保存してブックを閉じました。" & vbCrLf & vbCrLf & _

"【次のステップ】" & vbCrLf & _

"「工程2：テキスト取り込み」を実行してください。", vbInformation, "工程1完了"

Else

' 保存がキャンセルされた場合

MsgBox "保存がキャンセルされたため、作成したブックを破棄して終了します。", vbExclamation, "処理中断"

newBook.Close SaveChanges:=False

End If

End Sub

モジュール2

Sub Step2_ImportText_BlockLimit10()
    Dim targetFile As Variant
    Dim targetBook As Workbook
    Dim ws As Worksheet
    Dim fdTxt As FileDialog
    Dim fullText As String, txtParts() As String, lineParts() As String
    Dim i As Long, txtIdx As Long, lineIdx As Long
    Dim modeSelect As VbMsgBoxResult
    Dim blockStartRow As Long: blockStartRow = 2 ' 各「◇」の開始行
    Dim currentLineOffset As Long ' ブロック内での行オフセット

    MsgBox "【工程2：テキスト取り込み】を開始します。" & vbCrLf & _
           "改行がある場合は下の行へ配置し、10行目を超える分は10行目にまとめます。", vbInformation, "工程2開始"

    targetFile = Application.GetOpenFilename("Excelブック (*.xlsx; *.xlsm),*.xlsx;*.xlsm", , "【Excel選択】マニュアル(Excel)を選択してください")
    If targetFile = False Then Exit Sub
    
    Set targetBook = Workbooks.Open(targetFile)
    On Error Resume Next
    Set ws = targetBook.Sheets("手順")
    On Error GoTo 0

    If ws Is Nothing Then
        MsgBox "「手順」シートが見つかりません。", vbCritical
        targetBook.Close SaveChanges:=False
        Exit Sub
    End If

    ' --- 既存データの確認とモード選択 ---
    If Application.WorksheetFunction.CountA(ws.Columns("H")) > 0 Then
        modeSelect = MsgBox("H列に既にテキストが存在します。" & vbCrLf & vbCrLf & _
                            "【はい】：既存のテキストを削除して上書きする" & vbCrLf & _
                            "【いいえ】：続き（空白行）から追加する" & vbCrLf & _
                            "【キャンセル】：処理を中止する", vbYesNoCancel + vbQuestion, "データ競合の確認")
        
        If modeSelect = vbCancel Then
            targetBook.Close SaveChanges:=False
            Exit Sub
        ElseIf modeSelect = vbYes Then
            ws.Columns("H").ClearContents
        Else
            ' 続きから（最終行の次のブロック開始位置を計算）
            blockStartRow = ws.Cells(ws.Rows.Count, "H").End(xlUp).Row
            blockStartRow = ((Int((blockStartRow - 2) / 10) + 1) * 10) + 2
        End If
    End If

    ' --- テキストファイル読み込み (UTF-8) ---
    Set fdTxt = Application.FileDialog(msoFileDialogFilePicker)
    With fdTxt
        .Filters.Clear
        .Filters.Add "テキストファイル", "*.txt", 1
        If .Show = False Then GoTo CancelExit
        
        Dim adoStream As Object
        Set adoStream = CreateObject("ADODB.Stream")
        With adoStream
            .Charset = "UTF-8"
            .Open
            .LoadFromFile fdTxt.SelectedItems(1)
            fullText = .ReadText
            .Close
        End With
    End With

    ' --- 流し込み処理 ---
    txtParts = Split(fullText, "◇")
    
    For txtIdx = 0 To UBound(txtParts)
        Dim blockText As String
        blockText = Trim(txtParts(txtIdx))
        
        If blockText <> "" Then
            ' 改行で分割
            blockText = Replace(blockText, vbCrLf, vbLf)
            blockText = Replace(blockText, vbCr, vbLf)
            lineParts = Split(blockText, vbLf)
            
            currentLineOffset = 0 ' ブロック内の書き込み位置リセット (0～8)
            
            For lineIdx = 0 To UBound(lineParts)
                Dim targetStr As String
                targetStr = Trim(lineParts(lineIdx))
                
                If targetStr <> "" Then
                    ' 9行目（offset=8）までは普通に下の行へ
                    If currentLineOffset < 8 Then
                        ws.Cells(blockStartRow + currentLineOffset, "H").Value = targetStr
                        currentLineOffset = currentLineOffset + 1
                    Else
                        ' 10行目（offset=9）に到達した場合、それ以降の全行をここに結合して格納
                        Dim remainingText As String
                        Dim k As Long
                        For k = lineIdx To UBound(lineParts)
                            If Trim(lineParts(k)) <> "" Then
                                remainingText = remainingText & Trim(lineParts(k)) & vbCrLf
                            End If
                        Next k
                        
                        ' 最後の改行を除去して10行目にセット
                        If Len(remainingText) > 0 Then
                            ws.Cells(blockStartRow + 8, "H").Value = left(remainingText, Len(remainingText) - 2)
                        End If
                        
                        ' この「◇」ブロックの処理を終了
                        Exit For
                    End If
                End If
            Next lineIdx
            
            ' 次の「◇」ブロックへ移動 (10行飛ばす)
            blockStartRow = blockStartRow + 10
        End If
    Next txtIdx

    MsgBox "工程2が完了しました。" & vbCrLf & _
           "1つのブロックに10行以上のデータがあった場合は、10行目に集約しました。" & vbCrLf & vbCrLf & _
           "上書き保存して閉じます。次は「工程3」を実行してください。", vbInformation, "工程2完了"
    targetBook.Close SaveChanges:=True
    Exit Sub

CancelExit:
    targetBook.Close SaveChanges:=False
End Sub

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

Sub Step2_ImportText_BlockLimit10()

Dim targetFile As Variant

Dim targetBook As Workbook

Dim ws As Worksheet

Dim fdTxt As FileDialog

Dim fullText As String, txtParts() As String, lineParts() As String

Dim i As Long, txtIdx As Long, lineIdx As Long

Dim modeSelect As VbMsgBoxResult

Dim blockStartRow As Long: blockStartRow = 2 ' 各「◇」の開始行

Dim currentLineOffset As Long ' ブロック内での行オフセット

MsgBox "【工程2：テキスト取り込み】を開始します。" & vbCrLf & _

"改行がある場合は下の行へ配置し、10行目を超える分は10行目にまとめます。", vbInformation, "工程2開始"

targetFile = Application.GetOpenFilename("Excelブック (*.xlsx; *.xlsm),*.xlsx;*.xlsm", , "【Excel選択】マニュアル(Excel)を選択してください")

If targetFile = False Then Exit Sub

Set targetBook = Workbooks.Open(targetFile)

On Error Resume Next

Set ws = targetBook.Sheets("手順")

On Error GoTo 0

If ws Is Nothing Then

MsgBox "「手順」シートが見つかりません。", vbCritical

targetBook.Close SaveChanges:=False

Exit Sub

End If

' --- 既存データの確認とモード選択 ---

If Application.WorksheetFunction.CountA(ws.Columns("H")) > 0 Then

modeSelect = MsgBox("H列に既にテキストが存在します。" & vbCrLf & vbCrLf & _

"【はい】：既存のテキストを削除して上書きする" & vbCrLf & _

"【いいえ】：続き（空白行）から追加する" & vbCrLf & _

"【キャンセル】：処理を中止する", vbYesNoCancel + vbQuestion, "データ競合の確認")

If modeSelect = vbCancel Then

targetBook.Close SaveChanges:=False

Exit Sub

ElseIf modeSelect = vbYes Then

ws.Columns("H").ClearContents

Else

' 続きから（最終行の次のブロック開始位置を計算）

blockStartRow = ws.Cells(ws.Rows.Count, "H").End(xlUp).Row

blockStartRow = ((Int((blockStartRow - 2) / 10) + 1) * 10) + 2

End If

' --- テキストファイル読み込み (UTF-8) ---

Set fdTxt = Application.FileDialog(msoFileDialogFilePicker)

With fdTxt

.Filters.Clear

.Filters.Add "テキストファイル", "*.txt", 1

If .Show = False Then GoTo CancelExit

Dim adoStream As Object

Set adoStream = CreateObject("ADODB.Stream")

With adoStream

.Charset = "UTF-8"

.Open

.LoadFromFile fdTxt.SelectedItems(1)

fullText = .ReadText

.Close

End With

' --- 流し込み処理 ---

txtParts = Split(fullText, "◇")

For txtIdx = 0 To UBound(txtParts)

Dim blockText As String

blockText = Trim(txtParts(txtIdx))

If blockText <> "" Then

' 改行で分割

blockText = Replace(blockText, vbCrLf, vbLf)

blockText = Replace(blockText, vbCr, vbLf)

lineParts = Split(blockText, vbLf)

currentLineOffset = 0 ' ブロック内の書き込み位置リセット (0～8)

For lineIdx = 0 To UBound(lineParts)

Dim targetStr As String

targetStr = Trim(lineParts(lineIdx))

If targetStr <> "" Then

' 9行目（offset=8）までは普通に下の行へ

If currentLineOffset < 8 Then

ws.Cells(blockStartRow + currentLineOffset, "H").Value = targetStr

currentLineOffset = currentLineOffset + 1

Else

' 10行目（offset=9）に到達した場合、それ以降の全行をここに結合して格納

Dim remainingText As String

Dim k As Long

For k = lineIdx To UBound(lineParts)

If Trim(lineParts(k)) <> "" Then

remainingText = remainingText & Trim(lineParts(k)) & vbCrLf

End If

Next k

' 最後の改行を除去して10行目にセット

If Len(remainingText) > 0 Then

ws.Cells(blockStartRow + 8, "H").Value = left(remainingText, Len(remainingText) - 2)

End If

' この「◇」ブロックの処理を終了

Exit For

End If

Next lineIdx

' 次の「◇」ブロックへ移動 (10行飛ばす)

blockStartRow = blockStartRow + 10

End If

Next txtIdx

MsgBox "工程2が完了しました。" & vbCrLf & _

"1つのブロックに10行以上のデータがあった場合は、10行目に集約しました。" & vbCrLf & vbCrLf & _

"上書き保存して閉じます。次は「工程3」を実行してください。", vbInformation, "工程2完了"

targetBook.Close SaveChanges:=True

Exit Sub

CancelExit:

targetBook.Close SaveChanges:=False

End Sub

モジュール3

Sub Step3_ImportImages()
    Dim targetFile As Variant
    Dim targetBook As Workbook
    Dim ws As Worksheet
    Dim fdImg As FileDialog
    Dim imgList() As String
    Dim i As Long, imgIdx As Long
    Dim modeSelect As VbMsgBoxResult
    Dim startRow As Long: startRow = 2

    MsgBox "【工程3：画像取り込み】を開始します。" & vbCrLf & _
           "まず、画像を取り込みたい「Excelファイル」を選択してください。", vbInformation, "工程3開始"

    targetFile = Application.GetOpenFilename("Excelブック (*.xlsx; *.xlsm),*.xlsx;*.xlsm", , "【Excel選択】マニュアル(Excel)を選択してください")
    If targetFile = False Then Exit Sub
    
    Set targetBook = Workbooks.Open(targetFile)
    On Error Resume Next
    Set ws = targetBook.Sheets("手順")
    On Error GoTo 0

    If ws Is Nothing Then
        MsgBox "「手順」シートが見つかりません。", vbCritical
        targetBook.Close SaveChanges:=False
        Exit Sub
    End If

    ' --- 追加メッセージ ---
    MsgBox "Excelファイルの読み込みが完了しました。" & vbCrLf & _
           "次に、挿入したい「画像ファイル」をすべて選択してください。", vbInformation, "次の操作案内"

    ' --- 既存画像の確認 ---
    Dim shp As Shape, hasImages As Boolean
    For Each shp In ws.Shapes
        If Not Intersect(shp.TopLeftCell, ws.Columns("B")) Is Nothing Then
            hasImages = True: Exit For
        End If
    Next

    If hasImages Then
        modeSelect = MsgBox("B列に既に画像が存在します。" & vbCrLf & vbCrLf & _
                            "【はい】：既存の画像を削除して上書きする" & vbCrLf & _
                            "【いいえ】：続き（空白行）から追加する" & vbCrLf & _
                            "【キャンセル】：処理を中止する", vbYesNoCancel + vbQuestion, "画像競合の確認")
        
        If modeSelect = vbCancel Then
            targetBook.Close SaveChanges:=False
            Exit Sub
        ElseIf modeSelect = vbYes Then
            If MsgBox("B列の画像データをすべて消去します。元に戻せませんが本当によろしいですか？", _
                      vbOKCancel + vbExclamation, "最終確認") = vbCancel Then
                targetBook.Close SaveChanges:=False
                Exit Sub
            End If
            For Each shp In ws.Shapes
                If Not Intersect(shp.TopLeftCell, ws.Columns("B")) Is Nothing Then shp.Delete
            Next
        Else
            Dim maxRow As Long: maxRow = 0
            For Each shp In ws.Shapes
                If Not Intersect(shp.TopLeftCell, ws.Columns("B")) Is Nothing Then
                    If shp.TopLeftCell.Row > maxRow Then maxRow = shp.TopLeftCell.Row
                End If
            Next
            If maxRow < 2 Then
                startRow = 2
            Else
                startRow = ((Int((maxRow - 2) / 10) + 1) * 10) + 2
            End If
        End If
    End If

    ' --- 画像選択 ---
    Set fdImg = Application.FileDialog(msoFileDialogFilePicker)
    With fdImg
        .Filters.Clear
        .Filters.Add "画像ファイル", "*.jpg; *.jpeg; *.png; *.bmp", 1
        .Title = "【画像選択】挿入する画像を複数選択してください"
        If .Show = False Then GoTo CancelExit
        ReDim imgList(.SelectedItems.Count - 1)
        For i = 1 To .SelectedItems.Count: imgList(i - 1) = .SelectedItems(i): Next i
        ' ★ここでコンパイルエラーが出ていたため、下の関数を必ず同じモジュール内に貼ってください
        Call QuickSort_Single(imgList, LBound(imgList), UBound(imgList))
    End With

    ' --- 画像挿入 ---
    imgIdx = 0
    For i = startRow To 1002 Step 10
        If imgIdx <= UBound(imgList) Then
            Dim pic As Shape
            Set pic = ws.Shapes.AddPicture(fileName:=imgList(imgIdx), _
                LinkToFile:=False, SaveWithDocument:=True, _
                left:=ws.Cells(i, "B").left, Top:=ws.Cells(i, "B").Top, _
                Width:=-1, Height:=-1)
            pic.LockAspectRatio = msoTrue
            pic.Height = 4.75 * 28.346
            imgIdx = imgIdx + 1
        Else
            Exit For
        End If
    Next i
    
    MsgBox "工程3（すべての工程）が正常に完了しました。" & vbCrLf & _
           "Excelを上書き保存して閉じます。お疲れ様でした。", vbInformation, "工程3完了"
    targetBook.Close SaveChanges:=True
    Exit Sub

CancelExit:
    targetBook.Close SaveChanges:=False
End Sub

' --- 【重要】この関数がないと工程3でコンパイルエラーになります ---
Private Sub QuickSort_Single(v() As String, left As Long, right As Long)
    Dim i As Long, j As Long, pivot As String, tmp As String
    i = left: j = right: pivot = v((left + right) \ 2)
    Do
        Do While v(i) < pivot: i = i + 1: Loop
        Do While v(j) > pivot: j = j - 1: Loop
        If i <= j Then
            tmp = v(i): v(i) = v(j): v(j) = tmp
            i = i + 1: j = j - 1
        End If
    Loop While i <= j
    If left < j Then QuickSort_Single v, left, j
    If i < right Then QuickSort_Single v, i, right
End Sub

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

Sub Step3_ImportImages()

Dim targetFile As Variant

Dim targetBook As Workbook

Dim ws As Worksheet

Dim fdImg As FileDialog

Dim imgList() As String

Dim i As Long, imgIdx As Long

Dim modeSelect As VbMsgBoxResult

Dim startRow As Long: startRow = 2

MsgBox "【工程3：画像取り込み】を開始します。" & vbCrLf & _

"まず、画像を取り込みたい「Excelファイル」を選択してください。", vbInformation, "工程3開始"

targetFile = Application.GetOpenFilename("Excelブック (*.xlsx; *.xlsm),*.xlsx;*.xlsm", , "【Excel選択】マニュアル(Excel)を選択してください")

If targetFile = False Then Exit Sub

Set targetBook = Workbooks.Open(targetFile)

On Error Resume Next

Set ws = targetBook.Sheets("手順")

On Error GoTo 0

If ws Is Nothing Then

MsgBox "「手順」シートが見つかりません。", vbCritical

targetBook.Close SaveChanges:=False

Exit Sub

End If

' --- 追加メッセージ ---

MsgBox "Excelファイルの読み込みが完了しました。" & vbCrLf & _

"次に、挿入したい「画像ファイル」をすべて選択してください。", vbInformation, "次の操作案内"

' --- 既存画像の確認 ---

Dim shp As Shape, hasImages As Boolean

For Each shp In ws.Shapes

If Not Intersect(shp.TopLeftCell, ws.Columns("B")) Is Nothing Then

hasImages = True: Exit For

End If

If hasImages Then

modeSelect = MsgBox("B列に既に画像が存在します。" & vbCrLf & vbCrLf & _

"【はい】：既存の画像を削除して上書きする" & vbCrLf & _

"【いいえ】：続き（空白行）から追加する" & vbCrLf & _

"【キャンセル】：処理を中止する", vbYesNoCancel + vbQuestion, "画像競合の確認")

If modeSelect = vbCancel Then

targetBook.Close SaveChanges:=False

Exit Sub

ElseIf modeSelect = vbYes Then

If MsgBox("B列の画像データをすべて消去します。元に戻せませんが本当によろしいですか？", _

vbOKCancel + vbExclamation, "最終確認") = vbCancel Then

targetBook.Close SaveChanges:=False

Exit Sub

End If

For Each shp In ws.Shapes

If Not Intersect(shp.TopLeftCell, ws.Columns("B")) Is Nothing Then shp.Delete

Else

Dim maxRow As Long: maxRow = 0

For Each shp In ws.Shapes

If Not Intersect(shp.TopLeftCell, ws.Columns("B")) Is Nothing Then

If shp.TopLeftCell.Row > maxRow Then maxRow = shp.TopLeftCell.Row

End If

If maxRow < 2 Then

startRow = 2

Else

startRow = ((Int((maxRow - 2) / 10) + 1) * 10) + 2

End If

' --- 画像選択 ---

Set fdImg = Application.FileDialog(msoFileDialogFilePicker)

With fdImg

.Filters.Clear

.Filters.Add "画像ファイル", "*.jpg; *.jpeg; *.png; *.bmp", 1

.Title = "【画像選択】挿入する画像を複数選択してください"

If .Show = False Then GoTo CancelExit

ReDim imgList(.SelectedItems.Count - 1)

For i = 1 To .SelectedItems.Count: imgList(i - 1) = .SelectedItems(i): Next i

' ★ここでコンパイルエラーが出ていたため、下の関数を必ず同じモジュール内に貼ってください

Call QuickSort_Single(imgList, LBound(imgList), UBound(imgList))

End With

' --- 画像挿入 ---

imgIdx = 0

For i = startRow To 1002 Step 10

If imgIdx <= UBound(imgList) Then

Dim pic As Shape

Set pic = ws.Shapes.AddPicture(fileName:=imgList(imgIdx), _

LinkToFile:=False, SaveWithDocument:=True, _

left:=ws.Cells(i, "B").left, Top:=ws.Cells(i, "B").Top, _

Width:=-1, Height:=-1)

pic.LockAspectRatio = msoTrue

pic.Height = 4.75 * 28.346

imgIdx = imgIdx + 1

Else

Exit For

End If

Next i

MsgBox "工程3（すべての工程）が正常に完了しました。" & vbCrLf & _

"Excelを上書き保存して閉じます。お疲れ様でした。", vbInformation, "工程3完了"

targetBook.Close SaveChanges:=True

Exit Sub

CancelExit:

targetBook.Close SaveChanges:=False

End Sub

' --- 【重要】この関数がないと工程3でコンパイルエラーになります ---

Private Sub QuickSort_Single(v() As String, left As Long, right As Long)

Dim i As Long, j As Long, pivot As String, tmp As String

i = left: j = right: pivot = v((left + right) \ 2)

Do While v(i) < pivot: i = i + 1: Loop

Do While v(j) > pivot: j = j - 1: Loop

If i <= j Then

tmp = v(i): v(i) = v(j): v(j) = tmp

i = i + 1: j = j - 1

End If

Loop While i <= j

If left < j Then QuickSort_Single v, left, j

If i < right Then QuickSort_Single v, i, right

End Sub

参考サイト

Microsoft公式 VBA リファレンス
Excel FileDialog / Shapes / Workbook 操作に関する技術ブログ
UTF-8テキスト読み込み（ADODB.Stream）解説記事

補足：なぜ画像＋テキストマニュアルが重要なのか

動画マニュアルは 全体の流れを理解する には非常に便利です。
しかし、

知りたい操作だけを素早く探したい
「あの設定どこだっけ？」を後から確認したい

といった場面では不向きです。

その点、画像＋テキストのExcelマニュアルであれば、

Ctrl＋Fで全文検索できる
必要な手順だけを一瞬で確認できる
動画と併用することで理解度が大きく向上する

という強力なメリットがあります。

関連記事

【Gemini】バイブコーティングを試す｜ローカルHTMLツールの作成例

【エクセルVBA】指定列で指定文字列を含む、セル個数を集計するVBA

【エクセルVBA】特定の文字列を含むセルへ、一括で色を付けるVBA

関連記事