エクセルのシート上に複数の図を連続で配置する | ExcelVBA

エクセルのシートに大量の図を貼り付けたいんだけど、手作業だと大変すぎる。

こんなお悩みを解決します。

ExcelVBAを使って、保存している複数の図を連続でワークシートに貼り付ける方法です。

大量に貼り付ける作業自体も大変ですが、この例の元となった作業では、なんども図の修正がありました。このような場合は、自動での方法を考えた方が良いです。

目次

シートへの図の配置例

エクセルブックに2つのワークシートがある例です。

シート
  1. 一覧:配置する図の拡張子なしのファイル名
  2. 貼付先:図の配置先

ワークシート[一覧]

  • ファイル名:A列2行目から
  • ファイル保存先:セルD1

一覧の項目が多い場合はテーブル設定し、列挙型変数とクラスを使うと管理しやすいです。

ワークシート[一覧]

ファイル保存先の画像です。

ファイル保存先

ワークシート[貼付先]

ワークシート1ページに3行×3列=9枚配置する例です。

シート[貼付先]

グラフの配置順です。

シート[貼付先]

サンプルコード

印刷範囲の設定は省いています。

Sub sample()
    Const gyo As Integer = 16
    Const retu As Integer = 6
    Const gkaisu As Integer = 3
    Const rkaisu As Integer = 3
    Dim wb1 As Workbook, tWS As Worksheet, gWS As Worksheet
    Set wb1 = ThisWorkbook
    Set tWS = wb1.Worksheets("一覧")
    Set gWS = wb1.Worksheets("貼付先")
    Dim lastR As Long: lastR = tWS.Cells(Rows.Count, 1).End(xlUp).Row
    Dim fPATH As String: fPATH = tWS.Cells(1, 4)
    Dim fName As String
    Dim i As Long, j As Long, r As Integer, c As Integer
    Dim rNo As Long, cNo As Long
    Dim shp As Shape
    
    gWS.Select
    With gWS
    rNo = 1
    i = 2
        Do While i < lastR + 1
            cNo = 1
            For c = 1 To rkaisu
                For r = 1 To gkaisu
                      If i > lastR Then Exit For
                            fName = fPATH & tWS.Cells(i, 1) & ".png"
                       If Dir(fName) <> "" Then
                            Set shp = .Shapes.AddPicture( _
                                            Filename:=fName, _
                                            LinkToFile:=False, _
                                            SaveWithDocument:=True, _
                                            Left:=Cells(rNo + 1, cNo).Left, _
                                            Top:=Cells(rNo + 1, cNo).Top, _
                                            Width:=0, _
                                            Height:=0)
                                          With shp
                                            .ScaleHeight 0.5, msoTrue
                                            .ScaleWidth 0.5, msoTrue
                                          End With
                           gWS.Cells(rNo, cNo).Value = tWS.Cells(i, 1)
                           i = i + 1
                  rNo = rNo + gyo
                  Else
                    gWS.Cells(rNo, cNo).Value = fName & "ファイルなし"
                    i = i + 1
                    rNo = rNo + gyo
            End If
            Next r
            rNo = rNo - gyo * rkaisu
            cNo = cNo + retu
            If i > lastR Then
                rNo = rNo + gyo
                Exit For
            End If
        Next c
        rNo = rNo + gyo * gkaisu
    Loop
   End With
End Sub

印刷範囲を設定する場合は、ループを抜けた後に設定を追加します。

lastR = lastR - 1
Dim pGyo As Double: pGyo = WorksheetFunction.RoundUp(lastR / (gkaisu * rkaisu), 0) * (gyo * gkaisu)
gWS.PageSetup.PrintArea = "$A$1:$R$" & pGyo

コードの説明です。

簡単な説明
  • 2行目:配置の行方向の間隔
  • 3行目:配置の列方向の間隔
  • 4行目:配置の行方向の繰り返し回数
  • 5行目:配置の列方向の繰り返し回数
  • 17行目:ワークシート[一覧]を選択した状態で、「gWS.Select」がない場合は配置した図がずれることがあります。
  • 28~36行目:図の配置
  • 37~38行目:もとの図の50%の大きさに変更します
  • 40行目:図の左上にファイル名を設定します
目次