指定フォルダから一括でpngの画像を並べて貼り付けたい

Question

実現したいこと

指定フォルダからpngの画像を縦に並べて一括で貼り付けたい。

前提

◆「入力」と「出力用」のシートがあります。
・入力シートは画像の配置場所や、画像を貼り付けたシートを出力するシートです

・出力用シートは画像を貼り付けるシートであり、黄色い範囲に貼り付けて、1行開けて次のファイルを貼り付ける。としたいです。

◆処理の流れ（ざっくりですが大まかな流れ）
①エラーチェック（画像格納場所やpngの画像有無判定など）
②指定のフォルダから画像を取得
③出力用のシートをシートの末にコピー
④↑のシート名を変更
⑤↑のシートに画像はりつける
⑥完了ダイアログ
⑦入力シートに戻る

発生している問題・エラーメッセージ

ソースコードの「imgPathArray」に値が入らず、
While文が動かずに画像貼り付けをせずに終わってしまう。

該当のソースコード

Sub 画像貼り付け()

    Dim testCaseNo As String '001-01
    testCaseNo = Range("C6").Text '.TEXT でセル表示形式のまま取得する .Value だと入力値を取得してしまう
    
    Dim inputDir As String '画像を格納したフォルダまでのパス。例)C:\Users\userName\Downloads\画像
    inputDir = Range("C3").Text
    
    Dim outputDir As String 'エビデンスEXCELを格納するフォルダまでのパス。例)C:\Users\userName\Downloads\画像
    outputDir = Range("C4").Text
    
    Dim outputBookName As String '出力するBook名。例)SHOT15_STエビデンス_001-03_小型_OK
    outputBookName = Range("C9").Text
    
    Dim outputBookNamePath As String 'エビデンスを保存するフォルダとエビデンス名。例)C:\Users\userName\Downloads\画像\SHOT15_STエビデンス_001-03_小型_OK
    outputBookNamePath = outputDir + "\" + outputBookName
    
    
    '-----------------------------↓事前チェック処理↓-----------------------------
    
    'FileSystemObject設定(フォルダやファイルの操作に使う)
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    Dim imgNameArray As String
    imgNameArray = Dir(inputDir & "\" & "*.png")

    
    '画像格納フォルダの存在を確認
    If fso.FolderExists(inputDir) = False Then
    'フォルダが存在しない場合はメッセージを表示して処理を終了(vbCrLfは改行コード)
        MsgBox "指定の画像格納フォルダが存在しない為、処理を終了します。" & vbCrLf & "C3 セルのパスが正しいか確認してください。"
        End
    End If
    
    'エビデンス出力先フォルダの存在確認
        If fso.FolderExists(outputDir) = False = "" Then
        'フォルダが存在しない場合はメッセージを表示して処理を終了(vbCrLfは改行コード)
        MsgBox "エビデンス出力先のフォルダが存在しない為、処理を終了しました。" & vbCrLf & "C4 セルのパスが正しいか確認してください。"
        End
    End If
        
    '同フォルダのpngファイルのパスを全て取得

    '指定拡張子(.png)のファイルの存在確認
    If imgNameArray = "" Then
        MsgBox "指定フォルダに画像ファイル(.png)が存在しない為、処理を終了しました。" & vbCrLf & "C3 セルのパスのフォルダに画像が格納されているか確認してください。"
        End
    End If
  
    
    '指定拡張子(.png)のファイルの存在が確認できたら画像貼り付け処理開始
    
    '-----------------------------↓シート処理↓-----------------------------
    
    '出力用 のシートを末にコピーして追加
    Worksheets("出力用").Copy After:=Worksheets(Worksheets.Count)
    
    '末にコピーして追加したシートの名前をテストケースNoに変更する
    Sheets("出力用 (2)").Name = testCaseNo
            
    '一番右のシートを取得
    Dim wsEnd As Worksheet
    Set wsEnd = Sheets(Sheets.Count)
    
    '-----------------------------↓画像貼り付け処理↓-----------------------------
    
    '挿入する行を格納
    Dim in_row As Long
    in_row = 2
    
    '複数写真の貼り付け処理を開始
    Do While imgPathArray <> ""  ' <> はノットイコール
    
    '画像のファイル名を取得
    Dim imgName As String
    imgName = fso.GetBaseName(imgNameArray)
    
    Debug.Print inputDir & "\" & imgNameArray
    
    '最初はB2からAC21(21行28列)に画像を貼り付け
    With ActiveSheet.Pictures.Insert(inputDir & "\" & imgNameArray)
    .Width = wsEnd.Range(Sheet1.Cells(in_row, 1), wsEnd.Cells(in_row, 3)).Width
    .Top = wsEnd.Cells(in_row, 1).Top
    .Left = wsEnd.Cells(in_row, 1).Left
    End With
    DoEvents
    
    '貼り付けた画像の名前を取得して写真の横のセルに転記
    wsEnd.Cells(in_row + 2, 5).Value = imgName

    '14行間隔で挿入する
    in_row = in_row + 14
    
    '次の画像貼り付け処理へ
    imgPathArray = Dir()
    Loop
    
    Set fso = Nothing
        
    '入力シートに戻る
    Worksheets("入力").Activate
    Range("C3").Select
    
    MsgBox "写真の貼り付けが正常に完了しました。"
        
End Sub

試したこと

以下のサイト参考にしたところ、
ダイアログに取得した画像が一覧として表示されるのですが、
画像貼り付けはできずでした。。
http://officetanaka.net/excel/vba/tips/tips69.htm

補足情報（FW/ツールのバージョンなど）

こちらページを参考にして作成しています。
https://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q13254168948

引き続き自分でも調査していきますが、
有識者の方にご協力いただけたら幸いです。

また、VBAを触るのがはじめてなので、
動いている部分でも冗長であったり改善の余地等あると思いますので、
そういった部分のご指摘もいただけますと嬉しいです。

何卒よろしくお願い申し上げます。

Answer 1

73行目と93行目の変数ミスでした、、
imgPathArray → imgNameArray

Comments

[Risney]

このままコピーしてみようと思っている方に補足ですが、
丸コピで実行すると、画像がリンク形式で貼り付けりことになってしまい、
画像へのパスが切れると（画像ファイルの位置がずれる）と画像が表示されなくなるので、
「一旦切り取って、画像として貼り付ける」という処理が必要ですので注意です。
※リンク形式でよいのであれば問題ありません。