硬貨の絵を貼り付けるマクロがExcel2007だと上手く動作しないが?

Question 103.1 Excel VBA Borad (掲示板)より Previous Next
初めまして。 マクロを利用して学習教材(プリント)を作っています。
OSがxpでしたが、職場のパソコンがビスタ、Excel2007になりました。自宅はxp 2003のままです。
以下の VBAマクロ(2003で作りました)です。 2003と2007で動作が違っています。
    列m = Range("Ak1").Value
    金種 = Range("Aj1").Value
    列PP = Cells(行m, 列m).Value
    If 列PP > 0 Then
        For 列P = 1 To 列PP
            Cells(行, 列).Select
            ActiveSheet.Pictures. _
                Insert(fp & "¥お金のイラスト¥" & 金種 & ".bmp").Select
            列 = 列 + 2
        Next 列P
    End If
とういうマクロで、上図のように、お金の絵を並ぶように貼り付けています。
Excel2007だと、最初のセルに全て張り付いてしまいます。
ActiveSheet.Pictures.Insert().Select が問題だと思うのですが、どう直せばよいか分かりません。
原因(理由)と直し方を教えていただければ幸いです。 よろしくお願いします。
Answer   Copyright (C) 2010.10.2 永井善王
おっしゃるとおり、2003では正しく動作するのに、2007では特定のセルに全て貼り付いてしまいますね。
念のため2010で試してみましたら、正常に動作しました。
どうやら、Excel2007 VBAに固有の問題のようで恐らく原因は、「Pictures」が隠しオブジェクトであることと関係あるのかも知れません。
よって、
Pictures.Insert の代わりに Shapes.AddPicture を使ってみましょう。 そうすればExcel2007でも正常に動作すると思います。
下記マクロは、下図(クリックで拡大可能)のワークシートのように A1、B1、C1、A4セルに値が入力された状態で実行すると、100円硬貨が5個貼り付くはずですから、試してみてください。
Sub 硬貨の絵を並ぶように貼り付ける()
    行m = Range("A1").Value
    列m = Range("B1").Value
    金種 = Range("C1").Value
    列PP = Cells(行m, 列m).Value
    行 = 8
    列 = 1
    If 列PP > 0 Then
        For 列P = 1 To 列PP
            Cells(行, 列).Select
            選択セルに画像を挿入して高さと幅を同じにする
            列 = 列 + 2
        Next 列P
    End If
End Sub

100円硬貨
Private Sub 選択セルに画像を挿入して高さと幅を同じにする()
      フルパス = "C:\A\100Yen.bmp"
      Set 硬貨の絵 = ActiveSheet.Shapes.AddPicture(Filename:=フルパス, _
          LinkToFile:=True, SaveWithDocument:=False, Left:=Selection.Left, _
          Top:=Selection.Top, Width:=100#, Height:=100#) '画像を挿入
      With 硬貨の絵
          .ScaleHeight 1!, msoTrue              '同じ高さにする
          .ScaleWidth 1!, msoTrue               '同じ幅にする
      End With
End Sub
Shapes.AddPicture についてはVBEのヘルプを参照されるか、拙著「Excel VBA そのまま使える実用マクロ 500連発」をお持ちでしたらサンプルNo.304が参考になるでしょう。
では、上手くいくようになったらマクロをご披露ください。
ありがとうございました
お教えいただいたとおりに作り直してみました。 以下のマクロにしました。
Private Sub 画像のコピー()
'画像ファイルのパスの習得
    With ActiveWorkbook
        fp = .Path
    End With
    金種 = Range("Aj1").Value
    画像パス = fp & "¥お金のイラスト¥" & 金種 & ".bmp"
'列の初期値
    行PP = 7
    行 = 4
    行m = 5
    For 行P = 1 To 行PP
        列 = 3
'金種の写真の挿入
        列m = Range("Ak1").Value
        列PP = Cells(行m, 列m).Value
        If 列PP > 0 Then
            For 列P = 1 To 列PP
                Cells(行, 列).Select
'貼り付けるセルの位置を調べる
                With Cells(行, 列)
                    選択セルTop = .Top
                    選択セルLeft = .Left
                End With
'画像を選択したセルの位置に貼り付ける
                Set 画像 = ActiveSheet.Shapes.AddPicture(Filename:=画像パス, _
                LinkToFile:=True, SaveWithDocument:=False, Left:=選択セルLeft, _
                Top:=選択セルTop, Width:=50#, Height:=50#)
                With 画像
                    .ScaleHeight 1!, msoTrue    '同じ高さにする
                    .ScaleWidth 1!, msoTrue     '同じ幅にする
                End With
                列 = 列 + 2
            Next 列P
        End If
'次の問題の作成
        行 = 行 + 2
        行m = 行m + 1
    Next 行P
End Sub
早速、このマクロを利用したシートで金額の学習プリントを印刷して、宿題にだしました。
本当にありがとうございました。

Excel VBA Macro