Excelへの一括画像貼り付け

質問

よろしくお願いします。
Windows XP Pro SP2
Excel 2007

大量にあるjpg画像をExcelへ一括で貼りつけたく、
Web上でマクロを探していました。
下記がヒットしたので、使用してみたのですが、
良回答となっているどちらの方法を試しても
同じ場所に貼り付けられるだけで
ちゃんと並んでくれませんでした。
なぜでしょうか？
http://oshiete1.goo.ne.jp/kotaeru.php3?q=1182506

また、上記マクロでなくとも、
大量にあるjpg画像をExcelへ
・縦に
・順番に
・統一されたサイズで
・一括で
貼りつけていくマクロをご存じでしたら教えてください。
どうぞよろしくお願いします。

回答No.5

xls88 · ベストアンサー

>次のように修正してマクロを実行したのですが、
>.ShapeRange.Width = ActiveCell.Resize(10).Width
>
>既存の１セルの横幅と同じサイズで画像が張り付けられました。
>なぜ横１０セル分の横幅にならないのでしょうか？

ヘルプからの抜粋ですが、Resizeプロパティの構文は
式.Resize(RowSize, ColumnSize)
です。
ActiveCell.Resize(10).Width
上記は、RowSize（行数）を指定しています。
ColumnSize（列数）を省略した書き方になっています。
RowSize（行数）を省略し、ColumnSize（列数）を指定した書き方に直してください。
尚、省略した場合は元のサイズが適用されます。

あと上の方にある
.ShapeRange.LockAspectRatio = msoTrue
で、縦横比が固定されています。
従って、省略した方の画像サイズは、縦横比が適用され自動的に変更されます。

お礼

ご回答ありがとうございます。
いろいろと教えてくださり感謝しております。

回答No.4

xls88

.ShapeRange.Height = 200
あるいは
.ShapeRange.Height = ActiveCell.Resize(25).Height
といった感じになります。

サイズに応じて、貼り付け先セルを調整する必要が出てきます。
ActiveCell.Offset(2, 0).Activate

お礼

ご回答ありがとうございます。
教えてくださった点を修正して試してみました。
うまく貼り付けることができました。

ただ、さらに、試しに下記の部分を
.ShapeRange.Height = ActiveCell.Resize(25).Height

次のように修正してマクロを実行したのですが、
.ShapeRange.Width = ActiveCell.Resize(10).Width

既存の１セルの横幅と同じサイズで画像が張り付けられました。
なぜ横１０セル分の横幅にならないのでしょうか？

回答No.3

xls88

With pict
　　'.TopLeftCell = ActiveCell '(1)ここを止めて(2)(3)にする
　　.Top = ActiveCell.Top　'(2)
　　.Left = ActiveCell.Left　'(3)
　　.ShapeRange.LockAspectRatio = msoTrue
　　'どちらかをコメントアウト
　　.ShapeRange.Height = ActiveCell.Height 'セルの高さリサイズ
　　'.ShapeRange.Width = ActiveCell.Width 'セルの幅にリサイズ
　　ActiveCell.Offset(0, 1) = fName(i) 'ファイル名書込み
End With

お礼

アドバイスありがとうございます。
遅くなりましたが、試させていただきました。
教えてくださった点を修正することでエラーにならず、
また順番に並んでくれました。
確認ですが、セルのサイズに合わせることしかできない
ものなのでしょうか？
例えば、画像の左上だけをセルに合わせて、
そのまま(もしくは任意)のサイズで画像をはりつけるのは難しいことなのでしょうか。

回答No.2

misatoanna

> 大量にあるjpg画像をExcelへ
> ・順番に（？）
> ・統一されたサイズで
> ・一括で

すべての行高が18Pic、列幅が72Picのシートを前提に、指定した
ディレクトリの画像を、横4列で貼り付けます。
シートのA1に対象フォルダのフルパスを入力してから実行します。

Sub Album1()
　Dim FPath, FName, R, C, i, H, W
　Application.ScreenUpdating = False
　FPath = Range("A1").Value & "\"
　FName = Dir$(FPath & "*.*")
　Do While FName <> ""
　　i = i + 1
　　R = 10 * Int((i - 1) / 4) + 3　　'※１
　　C = 3 * ((i - 1) Mod 4) + 1　　　'※２
　　ActiveSheet.Cells(R, C).Select
　　ActiveSheet.Pictures.Insert(FPath & FName).Select
　　H = Selection.Height
　　W = Selection.Width
　　Selection.Height = 120　　　　　'※３
　　Selection.Width = 120 * W / H　 '※３
　　FName = Dir$
　Loop
　Application.ScreenUpdating = True
End Sub

縦１列のみの場合は、
※１：R = 10 * (i - 1) + 3
※２：削除
です。

※３は写真のサイズを指定しています。
サイズを変更する場合は、貼り付けるセル位置（※１、※２）も
変更したほうがよいでしょう。

お礼

ありがとうございます。
参考にさせていただきます。
＃実験してみて、結果を連絡します。

補足

実験させていただきました。
＜状況＞
教えてくださったコードをそもまま使いましたところ、
やはり同じ個所に画像が貼り付けられてしまい、
並んではくれませんでした。

また、「縦１列のみの場合」も試してみましたが、こちらは
「１：R = 10 * (i - 1) + 3」の次の行でエラーとなるようです。
(エラーになりデバッグ画面を開いたところ上記が示されました)

回答No.1

xls88

.TopLeftCell = ActiveCell
のところですが、
PictのTopとLeftプロパティを、ActiveCellのTopとLeftプロパティにしてみてください。

お礼

ありがとうございます。
参考にさせていただきます。

補足

その後、まだ調べ中ですが、変え方がいまいち解りません・・・。