画像をエクセルに貼り付けるマクロ

画像をエクセルに貼り付けるマクロ

複数の画像をエクセルに貼り付ける機会が多く、下記のマクロを利用しています。これは他人が作ったものでその人が今はいないため修正の仕方がわかりません。
これだとヨコに2個の画像で縦方向に画像が貼り付けられます。これをヨコに3個の画像で
縦方向に画像を貼り付けるようにしたいのですが、方法がわかりません。
お詳しい方どうかよろしくお願いします。

＜現在＞
１　　２

３　　４

５　　６

＜やりたいこと＞
１　　２　　３

４　　５　　６

７　　８　　９

Sub Insertpic()

Dim strFilter As String
Dim Filenames As Variant
Dim pic As picture
Dim sc As Range
Dim i As Long
Dim j As Long
Dim k As Long

'「ファイルを開く」ダイアログでファイル名を取得
strFilter = "画像ファイル(*.jpg;*.jpeg;*.gif;*.bmp;*.png),*.jpg;*.jpeg;*.gif;*.bmp;*.png"
Filenames = Application.GetOpenFilename( _
FileFilter:=strFilter, _
Title:="画像の挿入(複数画像が選択できます）", _
MultiSelect:=True)
If Not IsArray(Filenames) Then Exit Sub

' 貼り付け開始セルを選択
'ActicveCellRange("C5").Select

' マクロ実行中の画面描写を停止
Application.ScreenUpdating = False
' 順番に画像を挿入
For i = LBound(Filenames) To UBound(Filenames)
Set pic = ActiveSheet.Pictures.Insert(Filenames(i))

'画像の大きさ指定
With pic.ShapeRange
.Height = 120#
.Width = 175#
.Rotation = 0#
End With

' 次の貼り付け先を選択
Select Case i Mod 2
Case 1 '奇数回目
ActiveCell.Offset(, 4).Select
Case 0 '偶数回目
ActiveCell.Offset(11, -4).Select
End Select

Set pic = Nothing
Next i

' 終了
Application.ScreenUpdating = True
MsgBox i - 1 & "枚の画像を挿入しました", vbInformation

End Sub

No.3 回答者： layy 回答日時： 2010/08/24 23:27

順番ですが、

For i = LBound(Filenames) To UBound(Filenames)
を
For i = 1 To UBound(Filenames)
にしてみても同じでしょうか。

この回答への補足

どうもありがとうございます。
試してみましたが結果は以前と同じでした。

補足日時：2010/08/25 08:24

No.2 回答者： kybo 回答日時： 2010/08/24 16:29

Excel2007以降でも正常に貼り付けできようにするには、さらに

With pic.ShapeRange
.Height = 120#
.Width = 175#
.Rotation = 0#
End With

を

With pic.ShapeRange
.Height = 120#
.Width = 175#
.Rotation = 0#
.Left = ActiveCell.Left
.Top = ActiveCell.Top
End With

としておいた方がよさそうです。

この回答へのお礼

ありがとうございます。
書き換えました。

お礼日時：2010/08/25 08:23

No.1 ベストアンサー 回答者： kybo 回答日時： 2010/08/24 16:21

Select Case i Mod 2

Case 1 '奇数回目
ActiveCell.Offset(, 4).Select
Case 0 '偶数回目
ActiveCell.Offset(11, -4).Select
End Select

の部分を

以下のように修正するだけでOKです。


Select Case i Mod 3
Case 2
ActiveCell.Offset(, 4).Select
Case 1
ActiveCell.Offset(, 4).Select
Case 0
ActiveCell.Offset(11, -8).Select
End Select

この回答へのお礼

どうもありがとうございました。無事におもったことができました。
もうひとつわかれば教えていただきたいのですが、
これで貼り付けると、ひとつのフォルダ内にいれた複数の写真で、一番最後の写真が一番最初に貼り付けられてしまいます（例えば、画像ファイル名が１、２、３、４、５とあると、５、１、２、３、４）という順番で張り付いてしまいます。１、２、３、４、５の順番ではりつけることができれば嬉しいです。

お礼日時：2010/08/24 17:42