エクセルマクロでサイズを指定して画像を一括貼り付けしたいです。

質問

エクセルマクロでサイズを指定して画像を一括貼り付けしたいです。

前任者が作成したマクロです。写真のサイズを指定したいのですができません。私はマクロ初心者の為このコードは難しくて理解できません。どうかよろしくお願い致します。

Sub 複数画像の挿入()
Dim c, sr, sc, s, rr, pkfile, ar, ac, rc, ccc, ca0
On Error GoTo err
Set a = Application.InputBox("画像挿入するセル選択" _
& Chr(13) & Chr(10) & "複数選択可" _
, "複数画像の一括挿入（セル選択）", Selection.Address, , , , , 8)
Application.ScreenUpdating = False
a.Select
sr = Selection.Row
sc = Selection.Column
rr = sr
pkfile = Application.GetOpenFilename _
("すべての図(*.emf;*.wmf;*.jpg;*.jpeg;*.jfif;*.jpe;*.png;*.bmp;*.gif), *.emf;*.wmf;*.jpg;*.jpeg;*.jfif;*.jpe;*.png;*.bmp;*.gif", 2, "挿入する図の選択（複数選択可）", , True)
If Not IsArray(pkfile) Then MsgBox "ファイルが指定されていません", , "複数画像の一括挿入": End
For fi = 1 To UBound(pkfile)
If pkfile(fi) = False Then MsgBox "ファイルが指定されていません", , "複数画像の一括挿入": End
Next fi
n = ActiveSheet.Pictures.Count
Application.DisplayAlerts = False
ar = a.Address
ac = Range(ar).Count
fi = 1
If ac > 1 Then GoTo ech Else GoTo pc
ech:
ca0 = ""
For Each cc In ActiveSheet.Range(ar)
ca = Range(cc.Address).MergeArea.Address
rc = Range(ca).Rows.Count
ccc = Range(ca).Columns.Count
If rc > 1 Or cc > 1 Then
ca = Cells(Range(ca).Row + rc - 1, Range(ca).Column + ccc - 1).Address
End If
If ca0 = ca Then GoTo mne
ca0 = ca
ca = Range(cc.Address).MergeArea.Address
Range(ca).Select

g = ActiveSheet.Pictures.Insert(pkfile(fi)).Name
fl = pkfile(fi)
fi = fi + 1
If fi = UBound(pkfile) + 1 Then GoTo en

mne:
Next
Application.DisplayAlerts = True
a.Select
Exit Sub

pc:
For fi = 1 To UBound(pkfile)
ca = Cells(rr, sc).Address
Range(ca).Select
g = ActiveSheet.Pictures.Insert(pkfile(fi)).Name
fl = pkfile(fi)
rr = rr + 1
Next fi
Exit Sub
en:
Application.DisplayAlerts = True
Application.ScreenUpdating = False

a.Select
Exit Sub
err: MsgBox "選択が正しくありません"
End Sub

回答No.2

end-u · ベストアンサー

ついでに。
Sub 複数画像の挿入() の動作にちょっと興味を惹かれましたので
習作してみました。
期待動作が違っていたら、こちらは捨て置いてください。

Sub try()
　　Dim a　 As Range
　　Dim cc　As Range
　　Dim W　 As Single
　　Dim H　 As Single
　　Dim mx　As Long
　　Dim fi　As Long
　　Dim i　 As Long
　　Dim pkfile

　　On Error GoTo extLine

　　With Application
　　　　Set a = .InputBox("画像挿入するセル選択" & vbLf & _
　　　　　　　　　　　　　"複数選択可", _
　　　　　　　　　　　　　"複数画像の一括挿入（セル選択）", _
　　　　　　　　　　　　　Selection.Address, _
　　　　　　　　　　　　　Type:=8)
　　　　pkfile = .GetOpenFilename("すべての図" & _
　　　　　　　　　　　　　"(*.emf;*.wmf;*.jpg;*.jpeg;*.jfif;" & _
　　　　　　　　　　　　　"*.jpe;*.png;*.bmp;*.gif)," & _
　　　　　　　　　　　　　"*.emf;*.wmf;*.jpg;*.jpeg;*.jfif;" & _
　　　　　　　　　　　　　"*.jpe;*.png;*.bmp;*.gif", 2, _
　　　　　　　　　　　　　"挿入する図の選択（複数選択可）", , True)
　　　　If Not IsArray(pkfile) Then
　　　　　　MsgBox "ファイルが指定されていません", , _
　　　　　　　　　 "複数画像の一括挿入"
　　　　　　GoTo extLine
　　　　End If
　　　　W = .InputBox("ヨコ", Type:=1)
　　　　H = .InputBox("タテ", Type:=1)
　　　　.ScreenUpdating = False
　　End With

　　mx = UBound(pkfile)
　　fi = 1
　　For Each cc In a
　　　　If cc.Address = cc.MergeArea.Item(1).Address Then
　　　　　　Call picIns(cc, pkfile(fi), W, H)
　　　　　　fi = fi + 1
　　　　　　If fi > mx Then
　　　　　　　　Set cc = Nothing
　　　　　　　　Exit For
　　　　　　End If
　　　　End If
　　Next

　　For i = fi To mx
　　　　Set a = a(a.Rows.Count, 1).Offset(1)
　　　　Call picIns(a, pkfile(i), W, H)
　　Next
extLine:
　　Set a = Nothing
　　Application.ScreenUpdating = False
　　With err()
　　　　If .Number <> 0 Then MsgBox .Number & ":" & .Description
　　End With
End Sub

Sub picIns(ByVal r As Range, _
　　　　　 ByVal s As String, _
　　　　　 ByVal W As Single, _
　　　　　 ByVal H As Single)

　　With ActiveSheet.Pictures.Insert(s).ShapeRange
　　　　If (W > 0) And (H > 0) Then
　　　　　　.LockAspectRatio = msoFalse
　　　　　　.Width = W
　　　　　　.Height = H
　　　　ElseIf W > 0 Then
　　　　　　.Width = W
　　　　ElseIf H > 0 Then
　　　　　　.Height = H
　　　　End If
　　　　.Left = r.Left
　　　　.Top = r.Top
　　End With
End Sub

お礼

ありがとうございました。
思い通りの動作になりました。感謝します。

回答No.1

end-u

挿入する複数の画像全て同じサイズにしたい、という解釈で良いですか？

その前提で話をすすめます。
ご提示のマクロで望みの動作ができているなら、
サイズ指定マクロを作成して、その中で Sub 複数画像の挿入()を呼び出し、
最後にサイズ変更すれば良いです。

Sub macro()
　　Dim W　As Single 'ヨコ
　　Dim H　As Single 'タテ
　　Dim mn As Long　 '挿入前の枚数
　　Dim i　As Long

　　W = Application.InputBox("写真サイズのヨコは？", Type:=1)
　　H = Application.InputBox("写真サイズのタテは？", Type:=1)

　　'挿入前の枚数を記憶しておいてSub 複数画像の挿入を呼び出す
　　mn = ActiveSheet.Pictures.Count
　　Call 複数画像の挿入

　　With ActiveSheet.Pictures
　　　　'挿入なしはExit Sub
　　　　If .Count = mn Then Exit Sub
　　　　For i = mn + 1 To .Count
　　　　　　.Item(i).Select False
　　　　Next
　　End With
　　'挿入写真のみ選択してサイズ変更
　　With Selection.ShapeRange
　　　　'W,Hとも指定した場合は縦横比変更して指定サイズに。
　　　　If (W > 0) And (H > 0) Then
　　　　　　.LockAspectRatio = msoFalse
　　　　　　.Width = W
　　　　　　.Height = H
　　　　'Wのみ指定は縦横比を保持してWのみ変更
　　　　ElseIf W > 0 Then
　　　　　　.Width = W
　　　　'Hのみ指定は縦横比を保持してHのみ変更
　　　　ElseIf H > 0 Then
　　　　　　.Height = H
　　　　'どちらも指定しなければサイズ変更しない。
　　　　Else
　　　　End If
　　End With
　　ActiveCell.Activate
End Sub

こんな感じです。
上記はApplication.InputBoxを使ってユーザーにサイズを入力してもらう例ですが、
固定値でも構わない場合は、InputBoxを使わず直接Width,Heightを指定してください。
If (W > 0) And (H > 0) Then...等の条件分岐も必要なくなります。