質問

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

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

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

通報する

回答 (2件)

ついでに。
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

この回答へのお礼

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

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

その前提で話をすすめます。
ご提示のマクロで望みの動作ができているなら、
サイズ指定マクロを作成して、その中で 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...等の条件分岐も必要なくなります。

このQ&Aは役に立ちましたか?5 件

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

新しく質問する

注目の記事

おしトピへのコメントで10人に1人に500円分のギフト券プレゼント!(先着2000名様)

話題のトピックにさくっとコメントできる「おしトピ」で指定のオーダー3件にコメントした方先着2000名様の10人に1人にギフト券をプレゼント!
フジテレビ出身のフリーアナウンサー長谷川豊氏の質問にも回答受付中!

このQ&Aを見た人が検索しているワード


新しく質問する

このカテゴリの人気Q&Aランキング

毎日見よう!教えて!gooトゥディ

べんりQ&A特集