Excel VBA入門 その100:Excelマクロでフォルダ内の画像をエクセル上に貼り付ける

エクセルVBA VBA



今回は、フォルダ内の画像をエクセルに一括で貼り付けるマクロを紹介します。



ファルダ内の画像をエクセルに一括で貼り付けするマクロ

フォルダに保存されている画像をエクセルのワークシート上に、選択した画像を自動でアルバムのように貼り付けるVBAです。
後から画像を追加できるように、マクロを起動するとインプットボックスが立ち上がり、画像を貼り付ける開始位置(開始セル)をマウスで選択できるようにしました。
画像の大きさはセルの大きさに合わせて、挿入時に自動的に調整される賢い(笑)機能付きです。
ぜひ活用してくださいね!

ファルダ内の画像を一括で貼り付けるマクロのサンプルコード:

Sub フォルダ内の画像を一括で貼り付けるマクロ()
  Dim i As Long , j As Long, k As Long
  Dim FileName As Variant
  Dim dblscal As Double
  Dim sp As Shape
  
  FileName = Application.GetOpenFilename( _
     filefilter:="画像ファイル,*.bmp;*.jpg;*.gif;*.JPG", _
     MultiSelect:=True)
     
  Dim inp As Range
  On Error Resume Next
  Set inp = Application.InputBox( _
     prompt:="マウスで開始セルを選択してください", _
     Title:="開始セルを選択", _
     Default:="マウスで開始セルを選択する", _
     Type:=8)         ''←メッセージボックスで開始セルを選択させる
     
  If Err.Number = 0 Then
     MsgBox mayrange.Address
  Else
     MsgBox "キャンセルしました。"
  End If
  
  j = inp.Row      ''←選択した開始セルの行
  k = inp.Column   ''←選択した開始セルの列
  
  For i = LBound(FileName) To UBound(FileName)
     Cells(j, k).Select
     With ActiveSheet.Shapes.AddPicture( _
        FileName:=FileName(i), _
        linktofile:=False, _
        savewithdocument:=True, _
        Left:=Selection.Left, _
        Top:=Selection.Top, _
        Width:=0, _
        Height:=0)
        
     .ScaleHeight 1, msoTrue
     .ScaleWidth 1, msoTrue
     
     If Cells(j, k).Width / .Width < Cells(j, k).Height / .Height Then
        dblscal = WorksheetFunction.RoundDown(Cells(j, k).Width / .Width, 2)
     Else
        dblscal = WorksheetFunction.RoundDown(Cells(j, k).Height / .Height, 2)
     End If
     
     .Width = .Width * dblscal * 0.97
     .Height = .Height * dblscal * 0.97
     .Left = .Left + (Cells(j, k).Width - .Width) / 2
     .Top = .Top + (Cells(j, k).Height - .Height) / 2
     End With
     
     k = k + 1
     If k > 5 Then   ''←折り返しの列はここを変える
        k = 1
        j = j + 1
     End If
    
  Next i
End Sub

画像を一括挿入する列数の変更方法

今回紹介したVBAは、5列で折り返しますが、もし画像の挿入の折り返しの列数を変更したい場合は、55行目の
If k > 5 Then
の「5」を希望の列数に変更することで対応できます。
ぜひ活用してくださいね!

コメント

  1. くろ子 より:

    先ほどコメントしましたくろ子です。
    こちらの部分を削除したら
    コメントにして読み込まないようにしてみたら
    うまくいきました。

    こちらのコード
    実務に使わせていただきます。
    ありがとうございました。

    • Tonperry Tonperry より:

      お返事が遅くなりました。
      うまくいって良かったです!
      実務のお役に立ててありがたいですm(_ _)m

タイトルとURLをコピーしました