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内での位置ズレを防ぎ、誰が見ても同じレイアウトになるように成果物を出力することができます。