複数の画像ファイルを一括でExcelシートに反映するマクロを作成しました

概要

ディレクトリ内にある複数の画像をExcelシートに1枚づつ貼り付ける作業があり
1枚づつ手作業でコピペ貼り付けは結構面倒なので、一括で張り付けるマクロを作成しました

以下のようにディレクトリに画像ファイルを配置

マクロを実行するとExcelにシートを作成し画像貼り付けされます

画像貼り付けサンプルマクロ

上記を実施させるマクロは以下のとおり

SampleMainメソッドで実施しているように
SetDirImageFile メソッドに対し、以下の引数値を設定し実行すると
指定のシートが作成され、画像が貼り付けされます
第１引数：画像を貼り付けるシート名（ない場合実行時に生成）
第２引数：張り付け対象画像があるディレクトリ
第３引数：張り付け方向　0:横方向　1:縦方向

既存のマクロから、画像の貼り付けのみを実施したいのであれば
PastePicture　メソッドのみを実行してください
第１引数：貼り付け画像のファイルパス
第２引数：画像の並べる間の間隔
第３引数：画像の並べる方向 0:横 1:縦

'貼り付けマクロ実行メソッド
Sub SampleMain()
    '貼り付けシート名「imgSheet」、
    '取り込み対象画像のディレクトリ「"C:\tmp\img"」
    '貼り付け方向「0」(横方向）
    SetDirImageFile "imgSheet", "C:\tmp\img", 0

End Sub

'フォルダ内の画像ファイルをEXCELに張り付ける
'　sheetName:画像を張り付けるシート名
'　imageFileDirPass:貼り付け対象画像のディレクトリパス
'　direction:画像の並べる方向 0:横 1:縦
Function SetDirImageFile(sheetName As String, imageFileDirPass As String, direction As Integer)

    Dim fileName As String
  
    '------------シートを作成
  
    'シートがすでに存在する場合は削除
    'Dim ws As Worksheet
    'Dim flag As Boolean
    'flag = False
    'For Each ws In Worksheets
    '    If ws.Name = sheetName Then
    '        flag = True
    '        Exit For
    '    End If
    'Next ws
    
    'If flag = True Then
    '    Application.DisplayAlerts = False '削除確認をOFFにする
    '    Sheets(sheetName).Delete
    '    Application.DisplayAlerts = True
    'End If
    
    'シートを追加
    Worksheets.Add
    ActiveSheet.Name = sheetName
    
    '貼り付け開始位置 縦、横２セル目から貼り付け開始
    ActiveCell.offset(2, 2).Select
    
    '------------Dir内のファイルを読取り貼付け
    
    'Dir内のファイルリストを取得
    '取り込み対象の画像ファイル名、拡張子を指定したい場合はここで指定
    buf = Dir(imageFileDirPass & "\*.*") 
    Do While buf <> ""
        
        If buf <> "" Then
        
            filePath = imageFileDirPass & "\" & buf
            
            '画面イメージを貼り付け
            PastePicture CStr(filePath), 2, direction
        
        End If
        
        buf = Dir()
    Loop
      
End Function

'画像を貼り付ける
'　filePath:画像ファイルパス
'　offset:画像の並べる間の間隔
'　direction:画像の並べる方向 0:横 1:縦
Sub PastePicture(filePath As String, offset As Integer, direction As Integer)
    Dim picture As Shape
    
    Set picture = ActiveSheet.Shapes.AddPicture( _
        fileName:=filePath, _
        LinkToFile:=False, SaveWithDocument:=True, _
        Left:=Selection.Left, Top:=Selection.Top, _
        Width:=0, Height:=0)

    picture.ScaleHeight 1!, msoTrue
    picture.ScaleWidth 1!, msoTrue
    
    '次の貼り付け位置にセルを移動
    If direction = 0 Then
        MoveRight picture.Width, offset
    Else
        MoveDown picture.Height, offset
    End If
    
End Sub

'画像の範囲分Cellを下に移動
'　pt:画像のポイント
'　offset:画像の並べる間の間隔(Pixel単位)
Sub MoveDown(pt As Double, offset As Integer)
    Dim moved As Double
    
    moved = 0
    Do While moved <= pt
        'ActiveCell.heightはポイント単位
        moved = moved + ActiveCell.Height
        ActiveCell.offset(1, 0).Activate
    Loop
    ActiveCell.offset(offset, 0).Activate
End Sub

'画像の範囲分Cellを右に移動
'　pt:画像のポイント
'　offset:画像の並べる間の間隔(Pixel単位)
Sub MoveRight(pt As Double, offset As Integer)
    Dim moved As Double
    
    moved = 0
    Do While moved <= pt
        'ActiveCell.widthはポイント単位
        moved = moved + ActiveCell.Width
        ActiveCell.offset(0, 1).Activate
    Loop
    ActiveCell.offset(0, offset).Activate
End Sub