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

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

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

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

シートへの図の配置例

エクセルブックに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

コードの説明です。