【Excel VBA】指定したフォルダ内の画像を等間隔で一斉に貼り付けるマクロ

f:id:Psuke222:20190930162149j:image

はじめに

こんにちは、YUMAです！

Excelに大量の画像を横位置を揃えて、間隔を一定にして貼り付けていくような作業をしたことはありますか？

こんな作業、手作業でやっていたらとても時間がかかりますし、何より面倒ですよね。

そこで、今回はこんな面倒な作業を一瞬で終わらせるExcelマクロをご紹介します。

フォルダ内の画像を一斉に貼り付けるマクロ

概要

今回紹介するマクロの概要は以下です。

選択したセルを左上にして、指定したフォルダ内の画像を下に向かって一斉に貼り付ける。
画像のサイズは元のサイズ
画像の間隔は、画像の上端から次の画像の上端までの行数を指定する

コード

マクロのコードは以下です。

Sub 画像一斉貼り付け()
Dim top As Long
Dim objFile As Object
Dim objFldr As FileSystemObject
Dim spanStr As String
Dim span As Long
Dim dlg As FileDialog
Dim folderPath As String
Dim height As Long
Dim rc As Integer
Dim flg As Boolean

Application.ScreenUpdating = False

flg = False

    rc = MsgBox("現在選択されているセルを左上にして画像を挿入します。よろしいですか？", vbYesNo + vbQuestion, "確認")

    If rc = vbYes Then 'はいを選択した場合、マクロ実行

        Set objFldr = CreateObject("Scripting.FileSystemObject")

        Set dlg = Application.FileDialog(msoFileDialogFolderPicker) '画像ファイルが入っているフォルダを選択

        If dlg.Show = False Then Exit Sub 'ファイルを選択しなかった場合、マクロを終了

        folderPath = dlg.SelectedItems(1) '選んだフォルダのパスを格納

        Do
            spanStr = InputBox("画像の上端から次の画像の上端までの行数を入力してください")

            If StrPtr(spanStr) = 0 Then Exit Sub '入力ボックスに何も入力されなかった場合、マクロを終了

            If IsNumeric(spanStr) Then '数字が入力されたら、フラグをTruenにする
                flg = True
            Else
                MsgBox ("数値を入力してください") '数字が入力されなかった場合、左記のメッセージを表示

            End If

        Loop Until flg = True 'フラグがTrueになるまで繰り返す

        height = ActiveCell.height '選択したセルの行の高さを格納
        span = CLng(spanStr) '入力された行数をLong型に変換して格納
        span = span * height '行数×行の高さで、間隔を算出
        top = Selection.top '選択したセルを上端にする

        For Each objFile In objFldr.GetFolder(folderPath).Files '選択したフォルダ内のファイルをすべて見るまで繰り返す

            '画像を一斉に貼り付ける
            ActiveSheet.Shapes.AddPicture _
                    Filename:=objFile, _
                    linktofile:=False, _
                    savewithdocument:=True, _
                    Left:=Selection.Left, _
                    top:=top, _
                    Width:=-1, _
                    height:=-1

            top = top + span '一枚貼り付けるごとに上端を設定した間隔分あける

        Next

        Application.ScreenUpdating = True 'マクロ実行後の状態を表示する

        MsgBox ("画像の貼り付けが完了しました") '完了メッセージを表示する

    Else
        Exit Sub '最初にいいえを選択した場合、マクロを終了
    End If

End Sub

マクロ使用の流れ

左上にしたいセルを選択
マクロを実行
確認メッセージが表示させるので、「はい」を選択
貼り付けたい画像ファイルが入っているフォルダを選択
画像の上端間の行数を入力
画像が貼り付けられる
完了メッセージが表示される

画像のサイズを指定したい場合

貼り付ける画像のサイズを指定したい場合は、AddPictureメソッド内のWidth(幅)とheight(高さ)の値を「-1」から任意の値に変更してください。

おわりに

VBAはまだまだ初心者ですが、よかったら参考にしてみてください！