今回は、フォルダ内の画像をエクセルに一括で貼り付けるマクロを紹介します。
ファルダ内の画像をエクセルに一括で貼り付けするマクロ
フォルダに保存されている画像をエクセルのワークシート上に、選択した画像を自動でアルバムのように貼り付ける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」を希望の列数に変更することで対応できます。
ぜひ活用してくださいね!
コメント
先ほどコメントしましたくろ子です。
こちらの部分を削除したら
コメントにして読み込まないようにしてみたら
うまくいきました。
こちらのコード
実務に使わせていただきます。
ありがとうございました。
お返事が遅くなりました。
うまくいって良かったです!
実務のお役に立ててありがたいですm(_ _)m