結合したセルの中央に画像を配置したい

Question

指定されたのパスにある画像を、結合したセルの中央に配置されるコードを作りたく、以下のコードを作成しました。
※中央と書きましたが、実際は画像の縦又は横の長いほうをセルの長さに合わせ、短いほうの辺長に縦横比を掛けて調整しています。

Sub 範囲内画像()

Dim P As String
Dim Path As String

Dim PicFile As String
Dim Pi As Object
Dim Phi As Long
Dim Pwi As Long
Dim Chi As Long
Dim Cwi As Long

P = ThisWorkbook.Path
Path = P & "指定の画像パス" '1飛ばす予定（パス）
Srow = 5 '2飛ばす予定（行）
Scol = 5 '3 飛ばす予定 (列)
High = 6 '4飛ばす予定(結合するセル数)

''''画像サイズ取得部位
    If Path = "False" Then Exit Sub 'ﾃﾞｰﾀ無い場合
    Set Pi = LoadPicture(Path)
    Phi = CLng(Pi.Height * 0.0378)
    Pwi = CLng(Pi.Width * 0.0378)
    MsgBox Phi & " × " & Pwi
    
    ' MsgBox CLng(Pi.Width * 0.0378) & " × " & CLng(Pi.Height * 0.0378)

''''セルサイズ取得
    Range(Cells(Srow, Scol), Cells(Srow + High, Scol)).Select
    Chi = Selection.Height
    Cwi = Selection.Width
     MsgBox Chi & "と" & Cwi

'''画像の幅が大きい場合、セルの幅＝画像の幅、そうでない場合（Else）画像の高さ＝セルの高さ
   If Pwi > Phi Then
     w = Cwi
     rat = Cwi / Pwi '縮小幅の縦横比
     h = Phi * rat '’画像高さを縦横比に合わせる
   ElseIf Phi > Pwi Then

   '～縦が長いときのコード（省略）

   End If

   Range(Cells(Srow, Scol), Cells(Srow + High, Scol)).Merge 'ここで結合したセルの中央に画像を表示したいです。

    If Dir(Path) = "" Then'画像が無かった時の処理
      Range(Cells(Srow, Scol), Cells(Srow + High, Scol)) = "画像無し"
      Range(Cells(Srow, Scol), Cells(Srow + High, Scol)).Font.Size = 15
      Range(Cells(Srow, Scol), Cells(Srow + High, Scol)).VerticalAlignment = xlCenter
      Range(Cells(Srow, Scol), Cells(Srow + High, Scol)).HorizontalAlignment = xlCenter
    Else '画像貼り付け
      Set Shp = Worksheets(1).Shapes.AddPicture(Path, msoFalse, msoTrue, _
      Range(Cells(Srow, Scol), Cells(Srow + High, Scol)).Left, _
      Range(Cells(Srow, Scol), Cells(Srow + High, Scol)).Top, w, h)
      
       With Shp
        '横を中央寄せ
        .Left = .Left + (ActiveCell.Width - Shp.Width) / 2
        '縦を中央寄せ
        .Top = .Top + (ActiveCell.Height - Shp.Height) / 2
       End With

    End If
End Sub

terateil内に似たような質問が有った為、参考にし、最下部に
（参考URL：https://teratail.com/questions/8846）

       With Shp
        '横を中央寄せ
        .Left = .Left + (ActiveCell.Width - Shp.Width) / 2
        '縦を中央寄せ
        .Top = .Top + (ActiveCell.Height - Shp.Height) / 2
       End With

を追加しました。
内容的には、貼り付け位置（.Top）にセルの高さ（ActiveCell.Height）から貼り付けた画像の高さ（Shp.Height）を引いて2で割ったものを足しているので、問題ないように思うのですが、指定のセルの上部に張り付いたまま動きません。

原因＆対策をご教授いただければ幸いです。

Answer 1

MergeされているのでMergeAreaの高さが必要です。

.Top = .Top + (ActiveCell.MergeArea.Height - Shp.Height) / 2

Comments

[ice930]

結合したセルは「MergeArea」と入れないといけなかったんですね！
ありがとうございます！解決しました！！