Excel VBAマクロ解説：図形を画像としてコピー＆新シートに貼り付けるマクロ

はじめに

Excelでは、DPI（Dots Per Inch：解像度） の違いにより、図形や画像の配置位置がズレて表示されることがあります。
特にSI（システムインテグレーション）の現場では、Excel上にブラウザのキャプチャを貼り付け、そこに注釈や図形を追加して成果物として提出することが多いでしょう。

このとき、開発環境と顧客環境のモニタ解像度が異なると、図形と画像の相対位置がズレ、箇所がずれて伝わってしまうリスクがあります。これは納品品質の低下や顧客満足度の低下に直結する可能性があるため、図形と画像を一塊の画像として保存する手法 があると良いでしょう。

本記事では、Excel VBA を活用して、図形と画像をまとめて画像としてコピーし、別シートに貼り付ける自動処理の実装方法を詳しく解説します。

ワークフローの全体像

以下は、今回のVBAマクロの処理手順を図解したものです：

+-------------------+
| 新しいシートを作成 |
+---------+---------+
          |
          v
+--------------------------+
| 元シートを順に処理開始    |
+-----------+--------------+
            |
            v
+-------------------------------+
| 図形と画像の使用範囲を取得     |
+---------------+---------------+
                |
                v
+----------------------------------------+
| 取得範囲を画像としてコピー（CopyPicture） |
+---------------+------------------------+
                |
                v
+--------------------------------+
| 新しいシートの同じ位置に貼り付け |
+--------------------------------+
                |
                v
+----------------------------+
| 元シートは非表示に（任意） |
+----------------------------+

コード

'このプロシージャは、すべてのシートをループし、それぞれを画像化して新しいシートに保存します。
Sub SnapshotAllSheetsWithShapes()
    Dim ws As Worksheet, destSheet As Worksheet
    Dim pastedShape As Shape
    Dim imgIndex As Integer: imgIndex = 1
    Dim newSheetName As String
    Dim pasted As Boolean, retryCount As Integer
    Const MAX_RETRY As Integer = 20
    Dim captureRange As Range
    Dim prefix As String: prefix = "画像_"
    Dim beforeCount As Integer

    On Error GoTo ErrHandler
    Application.ScreenUpdating = False
    Application.EnableEvents = False

    For Each ws In ThisWorkbook.Worksheets
        If ws.Shapes.Count = 0 And Application.WorksheetFunction.CountA(ws.UsedRange) = 0 Then GoTo NextSheet
        Set captureRange = GetFullVisualRange(ws)
        If captureRange Is Nothing Then GoTo NextSheet

        ws.Activate
        captureRange.CopyPicture Appearance:=xlScreen, Format:=xlPicture

        newSheetName = CleanSheetName(prefix & Format(imgIndex, "00") & "_" & ws.Name)
        Set destSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        destSheet.Name = newSheetName

        beforeCount = destSheet.Shapes.Count
        retryCount = 0
        pasted = False

        Do
            destSheet.Paste
            DoEvents

            If destSheet.Shapes.Count = beforeCount + 1 Then
                Set pastedShape = destSheet.Shapes(destSheet.Shapes.Count)
                pasted = True
            Else
                retryCount = retryCount + 1
                Application.Wait Now + TimeValue("00:00:01")
            End If
        Loop Until pasted Or retryCount >= MAX_RETRY

        If Not pasted Then
            MsgBox "貼り付け失敗：" & destSheet.Name, vbExclamation
            Exit Sub
        End If

        With destSheet.Range("A1")
            pastedShape.Top = .Top
            pastedShape.Left = .Left
        End With

        ws.Visible = xlSheetHidden
        imgIndex = imgIndex + 1

NextSheet:
    Next ws

    MsgBox "全シート完了！表と図形を画像として保存しました。", vbInformation

ExitHere:
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Exit Sub

ErrHandler:
    MsgBox "エラー：" & Err.Number & " - " & Err.Description, vbCritical
    Resume ExitHere
End Sub

'図形（`Shape`）とセルデータ（`UsedRange`）を同時に考慮し、見た目に表示される範囲を確実に取得します。
Function GetFullVisualRange(ws As Worksheet) As Range
    Dim shp As Shape
    Dim topRow As Long, leftCol As Long, bottomRow As Long, rightCol As Long
    Dim hasData As Boolean: hasData = False

    topRow = Rows.Count
    leftCol = Columns.Count
    bottomRow = 1
    rightCol = 1

    If Application.WorksheetFunction.CountA(ws.UsedRange) > 0 Then
        With ws.UsedRange
            hasData = True
            topRow = WorksheetFunction.Min(topRow, .Row)
            leftCol = WorksheetFunction.Min(leftCol, .Column)
            bottomRow = WorksheetFunction.Max(bottomRow, .Row + .Rows.Count - 1)
            rightCol = WorksheetFunction.Max(rightCol, .Column + .Columns.Count - 1)
        End With
    End If

    If ws.Shapes.Count > 0 Then
        hasData = True
        For Each shp In ws.Shapes
            With shp.TopLeftCell
                topRow = WorksheetFunction.Min(topRow, .Row)
                leftCol = WorksheetFunction.Min(leftCol, .Column)
            End With
            With shp.BottomRightCell
                bottomRow = WorksheetFunction.Max(bottomRow, .Row)
                rightCol = WorksheetFunction.Max(rightCol, .Column)
            End With
        Next shp
    End If

    If hasData Then
        Set GetFullVisualRange = ws.Range(ws.Cells(topRow, leftCol), ws.Cells(bottomRow, rightCol))
    Else
        Set GetFullVisualRange = Nothing
    End If
End Function

'31文字制限と禁止文字（例：`/`, `\`, `*`）に対応するための補助関数です。
Function CleanSheetName(name As String) As String
    Dim badChars As Variant, replaceChars As Variant, i As Long
    badChars = Array("\", "/", ":", "*", "?", "[", "]")
    replaceChars = Array("￥", "／", "：", "＊", "？", "［", "］")
    For i = LBound(badChars) To UBound(badChars)
        name = Replace(name, badChars(i), replaceChars(i))
    Next i
    CleanSheetName = Left(name, 31)
End Function

補足：変数名の語源と設計意図

変数名	語源・意味
`ws`	`Worksheet`の略。処理中の元シート。
`destSheet`	`Destination Sheet`：出力先シート。
`imgIndex`	`Image Index`：画像シート名の連番。
`newSheetName`	`New Sheet Name`：作成したシートの名前。
`pastedShape`	`Pasted Shape`：貼り付けた図形オブジェクト。
`captureRange`	`Capture Range`：画像としてコピーする対象範囲。
`prefix`	`Prefix`：シート名に使用する接頭辞（例：画像_）。
`beforeCount`	`Before Count`：貼り付け前の図形数。貼り付け成否を確認するために使用。
`retryCount`	`Retry Count`：貼り付けのリトライ回数。
`pasted`	`Pasted`：貼り付け成功判定のブール値（True/False）。

失敗ケースの詳細と学び

VBAによる図形と画像の自動処理には、いくつかの実装上の落とし穴があります。
実際に発生した失敗ケースを共有します。

ケース1：コピー処理中にExcelがフリーズまたは強制終了する

発生原因：

Range.CopyPicture や Worksheet.Paste は、選択状態や画面描画のタイミングに依存しています。特に処理対象が多く、図形が密集している場合、コピーに時間がかかるため、Excelの応答が一時停止し、ユーザーが強制終了するケースが発生しました。

失敗例：

大量の図形を含むシートを一括コピーした場合、VBAがタイムアウトやエラーで停止。
一度の失敗で処理が全体停止。

解決策：

Application.Wait を使用して再試行（リトライ）処理を導入。
MAX_RETRY 回数まで貼り付けをリトライして、一定の耐障害性を確保。

ケース2：VBAの「選択に依存する」操作で処理が中断

発生原因：

VBAには、選択状態が前提のメソッドが多く存在します（例：Selection.Copy, ActiveSheet.Paste）。ウィンドウが最小化されていたり、操作が割り込まれたりすると、選択が外れ、処理が失敗します。

失敗例：

ユーザーが処理中に別シートを操作すると、対象が切り替わりコピー元が不明に。
他のアプリにフォーカスが移ることで Selection が無効に。

解決策：

Selection や ActiveSheet を極力使用せず、オブジェクト変数（例：ws や destSheet）で直接操作。
DoEvents を挿入して、イベントキューを消化しながら安全に処理。

ケース3：新しいシート名が31文字を超えエラー

発生原因：

Excelではシート名の最大文字数が31文字であり、これを超える名前で Worksheets.Add.Name = "xxx" を実行すると、エラー1004 が発生します。

失敗例：

元シートの名前が長く、接頭辞（画像_XX_）を付けたことで31文字超過。
処理途中でマクロが停止し、中途半端な状態に。

解決策：

CleanSheetName 関数で自動的に31文字に切り詰め。
禁止文字（*, /, \ など）も自動置換して安定動作を実現。

ケース4：空シートを処理して無意味な画像を作成

発生原因：

使用されていないシートにも UsedRange があると、無駄な画像を生成するケースがある。

失敗例：

セルに一度でもデータを入れた履歴があると、UsedRange は空にならない。
図形やセルにデータがないのに、空白画像を出力してしまう。

解決策：

If ws.Shapes.Count = 0 And CountA(UsedRange) = 0 Then による実質的な無内容判定を導入。
本当に何もないシートはスキップ対象とする。

ケース5：貼り付け結果が表示されない、形状が崩れる

発生原因：

画像として貼り付けたはずが、透明または空白のShapeとして貼り付けられることがあります。これは、画面更新が無効な状態や、コピー範囲が不完全な場合に起こります。

失敗例：

CopyPicture に失敗しても Paste が実行され、結果として空白Shapeだけができる。
図形の重ね順が失われ、文字が見えなくなる。

解決策：

destSheet.Shapes.Count を事前・事後で比較して、貼り付け成功を厳密にチェック。
コピー対象の Range を事前に GetFullVisualRange で確実に特定。

教訓まとめ

教訓	実装のヒント
処理は非同期や描画タイミングに注意	`DoEvents`, `Wait`, `ScreenUpdating` を活用
選択依存は避ける	`Selection` よりオブジェクト操作を優先
名前制限・禁止文字に注意	正規化関数で31文字制限と記号処理を導入
無意味な出力を避ける	空シートや無図形シートはスキップ
貼り付け確認は数で検証する	`Shapes.Count` で貼り付け判定

まとめ

本記事では、Excel VBAを活用して、図形と画像を一括でコピー・画像化し、新シートに貼り付ける手法を解説しました。Excel内での位置ズレを防ぎ、誰が見ても同じレイアウトになるように成果物を出力することができます。

参考リンク