業務で使えるシリーズ（マクロ：エビデンス整理）

業務で大量のキャプチャを取得し、その全てをExcelのシートに張り付けエビデンスとして提出する。
ということがありました。

1枚2枚のキャプチャなら手作業で実施してもいいのですが、何百枚、何千枚となると手作業では無理があります。
そのため、色々な方のマクロを参考にさせていただきながら、以下のようなマクロを作成してみました。

ご紹介させていただきます。

'PastePicturesマクロ
Sub PastePictures()
    Dim filenames As Variant, filename As Variant
    
    '画像ファイルを指定
    filenames = Application.GetOpenFilename( _
        FileFilter:="画像ファイル,*.png;*.jpg", _
        MultiSelect:=True)
    If IsArray(filenames) Then
        For Each filename In filenames
            '画像間を3行空ける
            PastePicture CStr(filename), 3
        Next filename
    End If
End Sub

Sub PastePicture(filename As String, offset As Integer)
    Dim picture As Shape
    
    Set picture = ActiveSheet.Shapes.AddPicture( _
        filename:=filename, _
        LinkToFile:=False, SaveWithDocument:=True, _
        Left:=Selection.Left, Top:=Selection.Top, _
        Width:=0, Height:=0)

    picture.ScaleHeight 1!, msoTrue
    picture.ScaleWidth 1!, msoTrue
    'picture.heightはポイント単位
    '(ピクセル単位に変換するには96/72を掛ける)
    MoveDown picture.Height, offset
End Sub

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