【VBA】画像を張り付けた際の位置の誤差

Question

お世話になっています。

フォルダの画像をエクセルに張り付けるVBAを作ろうとしています。

画像間隔をセル間としてコードを書きましたが、誤差が積み重なり枚数が多くなるとずれが生じてしまいます。
これを解決したいと思い、以下のコードを追加してみましたがうまくいきません。
With Selection
.ShapeRange.Top = ActiveCell.Top
.ShapeRange.Left = ActiveCell.Left
.Height = ActiveCell.Height
End With

画像をセルにぴったりと合うような補正がしたいです。
ループをしながら定期的に、セルの上部と画像の上部を合わせる操作をしたいのですがどのようにすればよいのでしょうか。

もしくは、画像の挿入位置をすべてセルで指定すればいいのでしょうが、以下の操作をセル位置を使い指定する方法がわかりません。
i = i + 1
If i Mod 4 = 1 Then
lngTop = lngTop + e * 17
Else: lngTop = lngTop + e + d
End If

ちなみに挿入の横方向の位置は、写真を見ていただければわかりやすいと思うのですがセルの横辺に一致しないような場所に挿入したいのでポイントで指定しています。

超初心者です。
宜しくお願いします。](80ebc6d9e57389633ea282425dca967f.png)

Sub 画像貼り付け()


Dim lngTop As Long
Dim objFile As Object
Dim objFldr As FileSystemObject
Dim TheShape As Shape
Dim i As Integer
Dim d As Single
Dim e As Single
  Dim ws As Worksheet

d = Range("A16").Top - Range("A4").Top
e = Range("A17").Top - Range("A16").Top
lngTop = e * 3

'ポスト

  Set objFldr = CreateObject("Scripting.FileSystemObject")
  Worksheets("ポスト").Activate
    
    
  i = 1
       For Each objFile In objFldr.GetFolder(ThisWorkbook.Path & "\ポスト").Files

        ActiveSheet.Shapes.AddPicture _
                Filename:=objFile, _
                LinkToFile:=False, _
                SaveWithDocument:=True, _
                Left:=9.5, _
                Top:=lngTop, _
                Height:=d, _
                Width:=252.834
                     
         With Selection
    
    
    .ShapeRange.Top = ActiveCell.Top
    .ShapeRange.Left = ActiveCell.Left
 
    .Height = ActiveCell.Height
    End With
    
     i = i + 1

          If i Mod 4 = 1 Then
             lngTop = lngTop + e * 17

          Else: lngTop = lngTop + e + d
         
          End If
          
     
    Next

End Sub



コード

Answer 1

dとeを一度しか計算していませんが、行の状況によってずれてきます。
ループの中で都度計算してください。

Comments

[tanetanetane]

そうなんですね...
VBAは難しいです。
もっと勉強します。

Answer 2

https://teratail.com/questions/277517
これで解決したのではないですか？

コードを追加します。
X座標は適宜調整してください。

Sub 画像貼り付け()

    Dim objFile As Object
    Dim objFldr As FileSystemObject
    Dim TheShape As Shape
    Dim i As Integer
    Dim x, y As Integer
    Dim r As Integer
    Dim h As Integer

    Const Y_NUM = 4          ' 何枚の画像を１グループとするか
    Const Y_ROWS = 13        ' １枚の画像とする行数（空行含む）

    Set objFldr = CreateObject("Scripting.FileSystemObject")

    i = 0
    For Each objFile In objFldr.GetFolder(ThisWorkbook.Path & "\picture").Files

        r = i * Y_ROWS + 1                      ' セル位置(列)を計算
        r = r + Int(i / Y_NUM)                  ' グループ間の空行を追加
        x = ActiveSheet.Cells(r, 1).Left        ' セルの座標(X)を取得
        y = ActiveSheet.Cells(r, 1).Top         ' セルの座標(Y)を取得
        h = ActiveSheet.Cells(r + Y_ROWS - 1, 1).Top - ActiveSheet.Cells(r, 1).Top  ' 画像の高さを計算

        ActiveSheet.Shapes.AddPicture _
            Filename:=objFile, _
            LinkToFile:=False, _
            SaveWithDocument:=True, _
            Left:=x, _
            Top:=y, _
            Width:=252.834, _
            Height:=h

        i = i + 1
    Next

End Sub

Comments

[tanetanetane]

昨日はありがとうございました。

お陰様でシートの上の方の写真であれば、ぴったりとはまりました。

しかし画像を十数枚貼り付けてくると誤差が積み重なるのかだんだんとずれてきます...

他のサイトで、エクセルのセルの高さは結構アバウトで羅線を入れたりすると高さが少し変化するとの記載を見ました。これが影響しているのかもしれません。

常に画像を横線にぴったりと合わせたいのですが...

[ttyp03]

リンクの質問は昨日のではなくその前のです。
セルの座標を利用しましょうという回答をしました。
それを実践していれば「誤差」という言葉は出てこないはずですが。

[tanetanetane]

試してみました。
画像間を枚数ごとに指定する以下のコードはどのようにしたらリンク先のコードに組み込めるでしょうか。
試行錯誤してますがうまくいきません。
頭が悪く申し訳ないですが、、よろしくお願いいたします。

i = i + 1

If i Mod 4 = 1 Then
lngTop = lngTop + e * 17

Else: lngTop = lngTop + e + d

[ttyp03]

前々回のコードを修正してみました。
ご確認ください。

[tanetanetane]

完成しました...!
何から何までありがとうございます。
とても勉強になりました。
本当にありがとうございます。