for文でAddPictureを利用すると指定した貼付け位置からズレる

Question

実現したいこと

100枚以上あるbmp画像をシートB列の2行目から順に貼り付けたいです。
A列の同一行に画像ファイル名が入力してあり（ 例：1 (1) ）、これと対応する名前の画像を同一行にAddPictureで張り付けようとしています。

発生している問題

添付のように画像数が増えるにつれて貼り付け位置がずれてしまいます。

　

直接の原因かどうかわかりませんが、Office2010からOffice365に変えてからずれるようになりました。
解決策をご存じでしたら何卒ご教示いただけないでしょうか。

該当のソースコード

Sub image01()
Dim i As Integer
Dim Name As String
Dim BmpName As String
Dim myShape As Shape

Application.ScreenUpdating = False

For i = 1 To 39
    Name = Cells(i + 1, 1)
    BmpName = "画像のパス"
    Cells(i + 1, 2).Select
    Set myShape = ActiveSheet.Shapes.AddPicture( _
          Filename:=BmpName, _
          LinkToFile:=False, _
          SaveWithDocument:=True, _
          Left:=Selection.Left, _
          Top:=Selection.Top, _
          Width:=155, _
          Height:=124)
Next

Application.ScreenUpdating = True

End Sub

Comments

[radames1000]

Nameは実際は使われてますか？提示されたコードでは使用されていないように見えます。

[kurage]

説明不足ですみません。コードの　
　BmpName = "画像のパス"　
が実際は
　BmpName = "C:\hoge\" + Name + ".bmp"
となっていまして、取得した名前と対応する画像を選ぶようにしております。

[radames1000]

含まれていたならよかったです！お手数をおかけしました。

Answer 1

過去に表示倍率に起因したバグがありました。
表示倍率が100%でないとずれてしまうものです。
その場合の対処を試してみてください。

Dim myZoom As Long
myZoom = ActiveWindow.Zoom
ActiveWindow.Zoom = 100

'処理

ActiveWindow.Zoom = myZoom

Comments

[kurage]

ご回答をいただき誠にありがとうございます。バグの可能性もあるのですね。
Application.ScreenUpdating = Falseの前に上３行を、
Application.ScreenUpdating = Trueの後に下１行を追加して実行してみましたが、ズレてしまいました。

[radames1000]

現象がこちらで再現しないので難しいですね。
可能ならコードを他のファイルに移して試してみてはいかがでしょう。
ファイル自体が悪ければ、という考えです。

[kurage]

色々と調べていただき、大変恐縮です。
お手元の環境では再現されないということで、コード以外の要因（ファイル、PC等）も疑ってみたいと思います。

[kurage]

別のPCで実行したところ、期待通りに添付されました。PCの問題でした。大変失礼致しました。

[radames1000]

いえいえ、PCが原因と分かってよかったです。