マクロを実行すると画像がズレてしまいます

Question

VBAで汎用のものを利用して以下のようなマクロを組んだのですが、画像を挿入すると少しずつずれていってしまいます。
原因が分かる人がいましたらご教授ください。
下のを見てもわかると思いますが、VBAについてはまったくの初心者です
よろしくお願いします。
またよろしければ1枚目でA3を指定すると2枚目もA3に重ねて貼ってしまうミスも訂正してくれると助かります。
Private Sub CommandButton1_Click()
    
　　Dim strFilter As String
    Dim Filenames As Variant
    Dim PIC       As Picture
    
    ' 「ファイルを開く」ダイアログでファイル名を取得
    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
  
    ' ファイル名をソート
    Call BubbleSort_Str(Filenames, True, vbTextCompare)
    
    ' 貼り付け開始セルを選択
    Dim ActCell As Range
    Set ActCell = ActiveCell
    
    ' マクロ実行中の画面描写を停止
    Application.ScreenUpdating = False
    ' 順番に画像を挿入
    For i = LBound(Filenames) To UBound(Filenames)
        Set PIC = ActiveSheet.Pictures.Insert(Filenames(i))
     
        '-------------------------------------------------------------
        ' 画像の各種プロパティ変更
        '-------------------------------------------------------------
        With PIC
            .Top = ActiveCell.Top        ' 位置：アクティブセルの上側に重ねる
            .Left = ActiveCell.Left      ' 位置：アクティブセルの左側に重ねる
            .Placement = xlMove          ' 移動するがサイズ変更しない
            .PrintObject = True          ' 印刷する
        End With
        With PIC.ShapeRange
            .LockAspectRatio = msoTrue   ' 縦横比維持
            ' 画像の高さをアクティブセルにあわせる
            ' 結合セルの場合でも対応
            .Height = 178.5
        End With
Static a
Static p
a = a + 1
b = (a - 1) / 4
c = (a - 2) / 4
d = (a - 3) / 4
e = a / 4

If b = Int(b) Then
p = 58 * b + 3
ElseIf c = Int(c) Then
p = 58 * c + 16
ElseIf d = Int(d) Then
p = 58 * d + 29
ElseIf e = Int(e) Then
p = 58 * (e - 1) + 42
End If

' 次の貼り付け先を選択（アクティブセルにする）[例：5個下のセル]
        Cells(p, 1).Select
    
        Set PIC = Nothing
    Next i
End Sub

end-u · Accepted Answer

Excelのバージョンは2007でしょうか？
もしそうなら[更新プログラムのチェック]を行って、プログラムのアップデイトをしてください。
以前は、Zoom100％以外の時に画像の貼り付け位置がずれるという不具合がありました。

念のためZoom制御を加えたコードです。

Private Sub CommandButton1_Click()
　Dim strFilter As String
　Dim Filenames As Variant
　Dim ActCell　 As Range
　Dim i　　　　 As Long
　Dim x　　　　 As Long　　'貼り付け先計算用
　Dim z　　　　 As Long　　'現状Zoom記録

'「ファイルを開く」ダイアログでファイル名を取得
　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

z = ActiveWindow.Zoom '■
　'ファイル名をソート
　Call BubbleSort_Str(Filenames, True, vbTextCompare)
　'■シート最終画像のTopLeftCell行を取得
　With ActiveSheet.Pictures
　　'CommandButtonなどもカウントしてしまうので『> 1』適宜修正必要
　　If .Count > 1 Then
　　　x = .Item(.Count).TopLeftCell.Row
　　Else
　　　'無い場合は-10+13で次に3になる
　　　x = -10
　　End If
　End With
　ActiveWindow.Zoom = 100
　'マクロ実行中の画面描写を停止
　Application.ScreenUpdating = False
　'順番に画像を挿入
　For i = LBound(Filenames) To UBound(Filenames)
　　'■ActCellの13行下に次のActCell（貼り付け先）をセット
　　If x Mod 58 = 42 Then
　　　x = x + 19
　　Else
　　　x = x + 13
　　End If
　　Set ActCell = ActiveSheet.Cells(x, 1)
　　With ActiveSheet.Pictures.Insert(Filenames(i))
　　　With .ShapeRange
　　　　.LockAspectRatio = msoTrue '縦横比維持
　　　　.Height = 178.5
　　　End With
　　　.Top = ActCell.Top　　　　　 '■位置：ActCellの上側に重ねる
　　　.Left = ActCell.Left　　　　 '■位置：ActCellの左側に重ねる
　　　.Placement = xlMove　　　　　'移動するがサイズ変更しない
　　　.PrintObject = True　　　　　'印刷する
　　End With
　Next i
　Set ActCell = Nothing
　Application.ScreenUpdating = True
　ActiveWindow.Zoom = z
End Sub

貼り付け開始はA3セルで、13行間隔で下へ貼り付ける、ただし4枚毎に19行間隔で貼り付ける、のが基本です。
要件が今一つ不明だったので、シートに画像があれば追加貼り付けするようにしてます。
常にA3セルから貼り付けるなら、既存画像を削除して実行するか、適宜コードを修正してください。

end-u · Answer

>..少しずつずれていってしまいます。
というのは、13行間隔で貼り付けたいが、4枚に1枚は19行間隔になってしまう、
という意味ですか？

元々そのような内容のコードみたいですが、やりたい事は
『ActiveCellから13行間隔で下に貼り付けていく』
という内容でいいのでしょうか？

その場合、最初の貼り付け先を選択して以下コード実行です。

Private Sub CommandButton1_Click()
　　Dim strFilter As String
　　Dim Filenames As Variant
　　Dim PIC　　　 As Picture
　　Dim i　　　　 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
　　' ファイル名をソート
　　Call BubbleSort_Str(Filenames, True, vbTextCompare)
　　' 貼り付け開始セルを選択（ActiveCellをActCellにセット）
　　Dim ActCell As Range
　　Set ActCell = ActiveCell
　　' マクロ実行中の画面描写を停止
　　Application.ScreenUpdating = False
　　' 順番に画像を挿入
　　For i = LBound(Filenames) To UBound(Filenames)
　　　　Set PIC = ActiveSheet.Pictures.Insert(Filenames(i))
　　　　'-------------------------------------------------------------
　　　　' 画像の各種プロパティ変更
　　　　'-------------------------------------------------------------
　　　　With PIC
　　　　　　.Top = ActCell.Top　　　　 ' ■位置：ActCellの上側に重ねる
　　　　　　.Left = ActCell.Left　　　 ' ■位置：ActCellの左側に重ねる
　　　　　　.Placement = xlMove　　　　' 移動するがサイズ変更しない
　　　　　　.PrintObject = True　　　　' 印刷する
　　　　End With
　　　　With PIC.ShapeRange
　　　　　　.LockAspectRatio = msoTrue ' 縦横比維持
　　　　　　' 画像の高さをアクティブセルにあわせる
　　　　　　' 結合セルの場合でも対応
　　　　　　.Height = 178.5
　　　　End With
　　　　'■現在のActCellの13行下に次のActCell（貼り付け先）をセット
　　　　Set ActCell = ActiveSheet.Cells(ActCell.Row + 13, ActCell.Column)
　　　　Set PIC = Nothing
　　Next i
　　Set ActCell = Nothing
　　Application.ScreenUpdating = True
End Sub

変更のポイントは■の行です。

マクロを実行すると画像がズレてしまいます

Excelのバージョンは2007でしょうか？

>..少しずつずれていってしまいます。

この回答への補足

似たような質問が見つかりました

このQ&Aを見た人はこんなQ&Aも見ています

関連するカテゴリからQ&Aを探す

このQ&Aを見た人がよく見るQ&A

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング