マクロ 写真を複数挿入

工事写真をエクセルに大量に貼り付けています。
一枚一枚貼っているととても時間がかかるので、選択した写真を一度に貼り付けられるマクロを探しています。
エクセルが分からないためサイトからコードを拝借して使っているのですが、うまくいかなくて困っています。

①リンク貼り付けになってしまう
Shapes.AddPictuerメソッドを使わないといけないらしいのですが、直し方が分かりません。

②結合セルにぴったり合わない
右側だけがはみ出したり、足りなかったりします。

エクセル2013を使っています。
普通セル→結合セル→普通セルと縦に並んでいて、
結合セルに写真がぴったりと張り付くようにしたいです。

以下使っているコード

Sub Test()
Dim fName,pict As Picture
fName=Application.GetOpenFilename("JPG,*.jpg",MultiSelect:=True)
If IsArray(fName)Then
For I=1 To UBound(fName)
Set pict=ActiveSheet.Pictures.Insert(fName(i))
pict.TopLeftCell=ActiveCell
pict.Width=ActiveCell.Width
pict.Height=ActiveCell.Height
ActiveCell.Offset(2,0).Activate
Next I
End If
End Sub

本当は自分で勉強するべきだとは思いますが、提出期限が近く焦っているので質問しました。
よろしくお願いします。

質問者からの補足コメント

• 今日試してみたところ、うまくいきました！
  すごくさくさく仕事が進みます！
  本当にありがとうございました(^^)
  
  ちなみになんですが、教えていただいたコードを少し変えて、
  1つ目の結合セルの次に4つ目の結合セルに写真を張り付けるようなコードにも出来るでしょうか。
  
  Offset(2,0)のところをOffset(6,0)にすれば
  いいのでしょうか。
  もし宜しければ教えてください。

  No.2の回答に寄せられた補足コメントです。 補足日時：2016/03/14 21:18

No.2 ベストアンサー 回答者： jmuiny 回答日時： 2016/03/12 10:26

結合されたセルの大きさぴったりに、リンクでなく写真入れるサンプルです。

Sub Test()
Dim fName As Variant
Dim pict As Shape
fName = Application.GetOpenFilename("JPG,*.jpg", MultiSelect:=True)
If IsArray(fName) Then
For i = 1 To UBound(fName)
With ActiveCell
Set pict = ActiveSheet.Shapes.AddPicture(Filename:=fName(i), LinkToFile:=False, SaveWithDocument:=True, _
Left:=.Left, Top:=.Top, Width:=.MergeArea.Width, Height:=.MergeArea.Height)
End With
ActiveCell.Offset(2, 0).Activate
Next i
End If
End Sub

この回答へのお礼

素早いご回答ありがとうございます！
嬉しいです(^^)
早速月曜日に試してみます‼︎

お礼日時：2016/03/12 12:54

No.3 回答者： jmuiny 回答日時： 2016/03/15 09:08

補足コメントより

いくつのセルを結合しているかによります。
データがこわれるわけではないので、ご自分でやってみる事をお勧めします。
そうしないとスキルアップになりませんので。

No.1 回答者： ママチャリ 回答日時： 2016/03/12 00:03

こんな感じで、できそうですが･･･あまり自信がないので、ご参考程度に。

Sub Test()
Dim fName, pict As Picture
Dim i
fName = Application.GetOpenFilename("JPG,*.jpg", MultiSelect:=True)
If IsArray(fName) Then
For i = 1 To UBound(fName)
Set pict = ActiveSheet.Pictures.Insert(fName(i))
pict.ShapeRange.LockAspectRatio = msoFalse
pict.ShapeRange.Width = ActiveCell.Width
pict.ShapeRange.Height = ActiveCell.Height

ActiveCell.Offset(2, 0).Activate
Next i
End If
End Sub

この回答へのお礼

ご回答ありがとうございます！
こんなに早く頂けるとは！
早速月曜日に会社で試してみます！(^^)

お礼日時：2016/03/12 12:52