VBAで画像（図形・オートシェイプ）の指定位置をずらさずに配置する

2021-11-20

連続でシートに画像を指定した位置に貼り付ける方法です。

使用の環境によってはずれが生じる可能性があります。
複雑なグラフで大量のデータを配置した場合、パソコンのスペックによってはフリーズすることがあります。
グラフを画像として貼りつ付けではなく、グラフの画像を一度保存しその画像を挿入する方法もあります。

画像の配置例

フォルダ内に保存されているエクセルブックを開き、グラフシートを画像として別ブックのシートに貼り付けます。

貼り付けもとのデータ

グラフシートのあるエクセルブックの保存先：F:\sample

シート「グラフ」の画面です。

このグラフシートを画像として保存します。

貼り付け先

貼り付け先のエクセルブックです。貼り付け先の行列はこのシートに設定します。理由は、コード内で指定すると複雑になることと、一覧に入力しておくと変更する場合簡単なためです。

B列・ファイル名：拡張子なしのもとデータのファイル名
C列・行：貼り付け先の行番号（タイトル入力先）
D列・列：貼り付け先の列番号
E列・配置：画像を配置したら「済」と表示します
セルG1：ファイル保存先のパス

シート「貼付先」の画面です。

画像貼り付け後です。

縦横2枚ずつの例です。この数はコードで変更可能です。

指定した行列に配置するサンプルコード

はじめに指定通りに配置できる例です。

サンプルコード

シート[一覧]をアクティブにした状態でマクロ実行する場合です。

Sub sample1()
    Dim sWB As Workbook, sWH As Worksheet, hWH As Worksheet
    Set sWB = ActiveWorkbook
    Set sWH = sWB.Worksheets("一覧")
    Set hWH = sWB.Worksheets("貼付先")
    Dim fPath As String: fPath = sWH.Cells(1, 7)
    Dim gNo As String, cName As String, fName As String
    Dim i As Long, r As Long, c As Long
    Dim shp As Shape
    Dim sCount As Long: sCount = 1    
    
    For i = 2 To sWH.Cells(Rows.Count, 1).End(xlUp).Row
        With sWH
             gNo = .Cells(i, 1)
             cName = .Cells(i, 2)
             r = .Cells(i, 3)
             c = .Cells(i, 4)
             fName = fPath & .Cells(i, 2) & ".xlsx"
        End With
    
        If Dir(fName) <> "" Then
             Workbooks.Open fName
             Charts(1).CopyPicture
             ActiveWorkbook.Close SaveChanges:=False
            
            hWH.Select
            With hWH
                    .Paste
                     Set shp = .Shapes(sCount)
                     hWH.Cells(r, c).Value = "No." & gNo & "_" & cName
             End With
             
             With shp
                 .Top = Cells(r + 1, c).Top
                 .Left = Cells(r + 1, c).Left
                 .LockAspectRatio = msoTrue
                 .Height = 280
            End With
             sCount = sCount + 1
            sWH.Cells(i, 5) = "済"
        End If
    Next i
End Sub

配置した図に名前（例：ファイル名の拡張子を除いた名前）を付けたい場合は、33行目のあとに「.Name = cName」を追加します。