エクセル マクロ 写真貼り付け

質問

エクセル　マクロ　写真貼り付け
よろしくお願いします。
以前ここで、エクセルに写真を張り付けるマクロのコードが乗っていたので、それを使わせていただいていたのですが、ＰＣを入れ替えてからうまく動作してくれません。どなたか修正個所を教えていただけると助かります。
ＯＳ　ビスタ　
エクセル　２００７

"data"シートに貼付する写真のあるフォルダのパス、写真ファイル名が張り付ける分だけ表記されていて、"picture"シートに"data"シートの指定した写真を張り付けていきます。
Ａ４用紙に以前はＢ３セル辺りから写真を指定の大きさに張り付け、次のページに移動してＢ３７セルＢ７１セルＢ１０５セルと写真貼り付けをしてくれましたが、ＰＣ入れ替え後から写真が１ページ目のＢ３セルに重ねて張り付けられてしまいます。
以前のように各ページに１枚ずつ写真を指定の大きさに張り付けるにはどうしたらよいのでしょうか。
以前はＯＳ　ＸＰ　　エクセル２００３でした。
マクロに関しては素人です。どうかよろしくお願いします。

Sub MakeThumbnail()
Cells.Select
Selection.RowHeight = 22.5
Dim myDataCnt As Long
Dim myNo As Long
Dim i As Long
Dim myRow As Long
Dim myName As String

myDataCnt = Worksheets("data").Range("A1").End(xlDown).Row
myNo = 1
myRow = 2

Worksheets("picture").Select
Do Until myNo > myDataCnt
myName = Worksheets("data").Cells(myNo, 1).Value

Cells(myRow, 2).Select
ActiveSheet.Pictures.Insert(myName).Select
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Width = 200#

myRow = myRow + 12
myNo = myNo + 1
Loop

End Sub

回答No.4

watabe007 · ベストアンサー

>Cells.Select
>Selection.RowHeight = 22.5

>写真が下に向かって、ずれて張り付けされました。
>Ａ４ぺーじに１枚ずつ貼り付けをしたかったのですが、
>myRow + 34　　こんな感じでずれる量を調整してみました。
毎回、行高を設定する必要があるのかな？
毎回、pictureシートが新規で作成されるとか

>Application.ScreenUpdating = False
>　　myDataCnt = Worksheets("data").Range("A1").End(xlDown).Row
>　　myRow = 2
>　　Worksheets("picture").Select
　　Cells.RowHeight = 22.5　　　　　'←１行追加してください。
>　　myZoom = ActiveWindow.Zoom
>　　ActiveWindow.Zoom = 100
>　　For myNo = 1 To myDataCnt

お礼

こんにちは。
さらに修正いただきありがとうございます。
行高の設定は最初からこうなっていたので、そのまま使っておりました。
いろいろ試してみましたが、やっぱりＶＢＡは難しいです。
今後の勉強課題といたします。
ありがとうございました。

回答No.3

watabe007

>Application.ScreenUpdating = True
・・・・・・・・・
・・・・・・・・・
>Application.ScreenUpdating = False
間違えました、下記のように訂正してください。

Application.ScreenUpdating = False
・・・・・・・・・
・・・・・・・・・
Application.ScreenUpdating = True

お礼

こんにちは。
早速のご教示ありがとうございます。
手直しまで入れていただき、大変お手数おかけしました。
本日仕事が休みのため、自宅のPCで動作確認してみました。
写真が下に向かって、ずれて張り付けされました。
Ａ４ぺーじに１枚ずつ貼り付けをしたかったのですが、
myRow + 34　　こんな感じでずれる量を調整してみました。
あとは仕事場で、調整しながらやってみます。
ありがとうございました。

回答No.2

watabe007

>写真が下に向かって、ずれて張り付けされました。
お試しください
Sub MakeThumbnail()
　　Dim myDataCnt As Long
　　Dim myNo As Long
　　Dim myRow As Long
　　Dim myName As String
　　Dim myZoom As Single

　　Application.ScreenUpdating = True
　　myDataCnt = Worksheets("data").Range("A1").End(xlDown).Row
　　myRow = 2
　　Worksheets("picture").Select
　　myZoom = ActiveWindow.Zoom
　　ActiveWindow.Zoom = 100
　　For myNo = 1 To myDataCnt
　　　　myName = Worksheets("data").Cells(myNo, 1).Value
　　　　With ActiveSheet.Pictures.Insert(myName)
　　　　　　.ShapeRange.LockAspectRatio = msoTrue
　　　　　　.ShapeRange.Width = 200#
　　　　　　.Left = Cells(myRow, 2).Left
　　　　　　.Top = Cells(myRow, 2).Top
　　　　End With
　　　　myRow = myRow + 12
　　Next
　　ActiveWindow.Zoom = myZoom
　　Application.ScreenUpdating = False
End Sub

回答No.1

myRange

ちょと無駄なところもあるようですが、それは置いといて、
下記■の間の２行を追加すると動作すると思いますが。

------------------------
ActiveSheet.Pictures.Insert(myName).Select
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Width = 200#

'■
Selection.ShapeRange.Top = Cells(myRow, 2).Top
Selection.ShapeRange.Left = Cells(myRow, 2).Left
'■

myRow = myRow + 12
myNo = myNo + 1
Loop
--------------------------------

以上です。

お礼

こんにちは。
早速のご教示ありがとうございます。
本日仕事が休みのため、自宅のPCで動作確認してみました。
写真が下に向かって、ずれて張り付けされました。
後は何行ずらすか、試行錯誤しながらやってみます。
ありがとうございました。