セルに画像挿入すると、右セルに移動するにつれて画像位置がずれるので、ずれていかないようにしたい

下記マクロプログラムで、
「任意のセルにダブルクリックでセルに合わせたサイズで写真を貼り付ける」
ことは成功するのですが、
写真を貼るセルが右方向に行くほど、少しずつ画像がセルからはみ出してしまいます。
（例えばA１だときっちりサイズが収まるが、D1、AA１など右に移動するとなぜか写真が
微妙にセルから右側にずれる。下方向（A6,A99）などはずれません。

このずれは直らないものなのか、もし直せるならどう書き換えたらよいか、

また、現在は写真サイズがセルに合うようにしているので、
もし、写真サイズを一回り小さくすれば解決するのであれば、
どのようにプログラムを書き換えたらよいか教えていただければ
と思い投稿しました。

マクロは初心者で複雑なものはわからないため、
どなたかわかる方いらっしゃいましたら、よろしくお願いいたします。

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, _
Cancel As Boolean)
Dim PicFile As Variant
Dim rX As Double, rY As Double

'［ファイルを開く］ダイアログボックスを表示
PicFile = Application.GetOpenFilename( _
"画像ファイル,*.jpg;*.jpeg;*.gif;*.tif;*.png;*.bmp")
If VarType(PicFile) = vbBoolean Then Cancel = True: Exit Sub


Application.ScreenUpdating = False

'画像を挿入
With ActiveSheet.Shapes.AddPicture(PicFile, msoFalse, msoTrue, Selection.Left, Selection.Top, -1, -1)
rX = Target.Width / .Width
rY = Target.Height / .Height
If rX > rY Then
.Height = .Height * rY
Else
.Width = .Width * rX
End If

'セルの中央（横方向/縦方向の中央）に配置
.Left = Target.Left + (Target.Width - .Width) / 2
.Top = Target.Top + (Target.Height - .Height) / 2
End With

Application.ScreenUpdating = True
Cancel = True
End Sub

No.1 ベストアンサー 回答者： x-1919 回答日時： 2021/06/09 19:48

貼り付けた画像 (Shape オブジェクト）の Width と Height が正しく取得てきていれば、少なくともセルからはみ出ることはなさそうに思えます。

私のところで確認したところ、同一画像を連続して貼り付けていっても全く同じようにずれることなく貼りつきました。

シートの列幅は全く同じになってることを確認したうえで、同じ画像ファイルを貼りてつけていってもD列あたりからずれていきますか？

この回答へのお礼

早速ご回答ありがとうございます、大変助かります。
ご質問いただいた件ですが、提携フォーマットになっていて、
シート列幅は一定です。
A列B列が結合セル、その次は、E列F列が結合セルになっています。
最初の方はわからないのですが、BA列など離れるにつれて、ずれてくる感じです。

お礼日時：2021/06/10 11:34