https://www.limecode.jp/entry/fungo/064-linked-picture-excel-camera-tool

Excel&VBA解説サイト「エクセルの神髄」様出題の問題集、
「VBA100本ノック」に対する私の回答と解説のページです。

100本ノックの出題リストはこちらから
excel-ubara.com

出題：リンクされた図（カメラ機能）

#VBA100本ノック 64本目
「元表1」「元表2」の2シートのA1からの表範囲を「リンクされた図」として「まとめ」シートに貼り付けてください。
貼り付け位置
・「元表1」はA1:J20の範囲へ
・「元表2」はA21:J40の範囲へ
※範囲内の縦横位置は任意
※再実行を考慮し、前回貼り付け分は削除してください。

リンクされた図

◇ 出題ページはこちら

ソースコード

Option Explicit

' 100本ノック064：リンクされた図（カメラ機能）
Sub 元表シートをまとめシートへリンクされた図として出力する()
    
    ' 前回画像の削除
    Call シート内のすべてのシェイプを削除する(WSまとめ)
    
    ' 元表1のコピー
    Call セル範囲をリンクされた図として出力する _
        (WS元表1.Range("A1").CurrentRegion, WSまとめ.Range("A1:J20"))
    
    ' 元表2のコピー
    Call セル範囲をリンクされた図として出力する _
        (WS元表2.Range("A1").CurrentRegion, WSまとめ.Range("A21:J40"))
    
End Sub

' セル範囲→リンクされた図として貼り付け
Sub セル範囲をリンクされた図として出力する _
    (コピー元範囲 As Range, 貼付先範囲 As Range)
    
    コピー元範囲.Copy
    
    Dim 貼付Picture As Picture
    Set 貼付Picture = 貼付先範囲.Worksheet.Pictures.Paste(link:=True)
    
    ' 縦横比を固定して幅を拡大
    貼付Picture.ShapeRange.LockAspectRatio = msoTrue
    貼付Picture.Width = 貼付先範囲.Width
    
    ' 高さがオーバーしていたら縮小
    If 貼付Picture.Height > 貼付先範囲.Height Then
        貼付Picture.Height = 貼付先範囲.Height
    End If
    
    ' 上寄せ・水平中央に位置調整
    貼付Picture.Top = 貼付先範囲.Top
    Dim width差 As Double: width差 = 貼付先範囲.Width - 貼付Picture.Width
    貼付Picture.Left = 貼付先範囲.Left + width差 / 2

End Sub

' すべての画像を削除
Sub シート内のすべてのシェイプを削除する(対象シート As Worksheet)

    Dim シェイプ As Shape
    For Each シェイプ In 対象シート.Shapes
        
        シェイプ.Delete
        
    Next

End Sub

' リンクされた図の削除（エラーが頻発するため不採用）
Sub リンクのある画像を削除する(対象シート As Worksheet)

    Dim 画像 As Picture
    For Each 画像 In 対象シート.Pictures
        
        If 画像.Formula <> "" Then
            画像.Delete
        End If
        
    Next

End Sub

解説

リンクされた画像を挿入する問題です。

画像はPictureオブジェクトを使って操作します。

このオブジェクトは既定では非表示のメンバーのため、
オブジェクトブラウザで非表示のメンバーを表示してからコーディングしましょう。

ただ、この「リンクされた図」機能は互換性のための機能で、
現在では推奨されておらず、Web版Excelでも表示することができません。

一応ソースコードにも置いておきましたが、
以下のコードはエラーを頻発するため使い物になりませんでした。

' リンクされた図の削除（エラーが頻発するため不採用）
Sub リンクのある画像を削除する(対象シート As Worksheet)

    Dim 画像 As Picture
    For Each 画像 In 対象シート.Pictures
        
        If 画像.Formula <> "" Then
            画像.Delete
        End If
        
    Next

End Sub