【Excel-VBA】エビデンス(スクリーンショット)を綺麗に並べて貼り付ける＆クリップボードを初期化するためのマクロ

はじめに

仕事で、よくエビデンスのためにExcelにスクリーンショットを貼り付けて残しておいたりするが、
綺麗に位置が揃わないのと、操作ミスで直前のスクリーンショットを貼り付けてしまったりするのを防ぐマクロ。
後でスクリーンショットを綺麗にするのが面倒なのでこのマクロをその時々でカスタマイズしている。
このマクロに関しては、ActiveSheetに対して処理を掛けるため、エビデンスを保存するExcelには入れなくても良いメリットがある。
プロジェクトによってはVBA禁止のところもあるらしいが今の所、そう言った現場には出会ってないのである意味助かってる？

このツールで実現したいこと

1.スクリーンショットが綺麗に並んで表示されていること
2.貼り付けミスを減らす(クリップボード初期化)
3.エラーや確認事項があった場合に、わかりやすくしたい。
基本的にこの３つだけ。

仕様(ざっくり)

1.対象の画面のプリントスクリーン済の状態からスタート
2.Excelの貼り付けたい位置にカーソルを置く(今回はA1を選択)
3.貼り付けマクロを実行(私の場合、オプション設定で、CTRL+Shift+Vで登録している。)
　貼り付ける際に、クリップボードが空の場合はエラーメッセージが出力されます。
4.選択したセル(イメージ上ではA1)の下２つ(イメージ上ではA2:A3)の中に貼り付けられる。
　ここで、A2:A3の背景色を変えてあげるとそのスクリーンショットが目立つ形になるためエラーや何かを知らせたい場合に便利である。
　ヘッダー部分にコメント(イメージ上ではA1)を記載することである程度内容がわかったりする。（基本的には未記入状態）
5.クリップボード内がクリアされ、選択したセルから、4つ下のセル位置にカーソルが移動する。
　次のスクリーンショットを貼り付けるための終了処理のイメージ。

イメージ

・初期位置選択

・貼付け後(Ctrl+Shift+V実行後)※各自で設定しないとショートカットキーに登録されない。

・エラーや警告があった場合のメモするイメージ

ソース(EXCEL-VBA)

Module1

Option Explicit

'プリントスクリーンの拡大率(80%)　->　100%の場合は1を指定。
Const 拡大率 = 0.8


'貼り付けるセルのサイズ調整
'セル内からはみ出たり、セルサイズが大きすぎたりする場合は調整必要。
Const ヘッダーサイズ = 18
Const CELL_SIZE_Y = 200
Const CELL_SIZE_X = 350


Sub エビデンスペースト()
    Dim tmp As Range
    Dim x, y As Integer
    Dim objShp As Shape
    y = CELL_SIZE_Y
    x = CELL_SIZE_X
    Application.ScreenUpdating = False
    Set tmp = ActiveCell
    tmp.Offset(1).Select
On Error GoTo エラー
    '貼り付けるシートのサイズ調整
    tmp.Offset(1).RowHeight = x
    tmp.Offset(2).RowHeight = x
    tmp.ColumnWidth = y
    tmp.RowHeight = ヘッダーサイズ
    '貼り付け処理
    ActiveSheet.Paste

    '貼り付けた際の、オートシェープ位置や拡大率を変更
    Set objShp = ActiveSheet.Shapes(Selection.Name)
    objShp.LockAspectRatio = msoTrue
    objShp.ScaleHeight 拡大率, msoTrue
    objShp.ScaleWidth 拡大率, msoTrue

    '大体貼り付け位置の中央付近に移動
    objShp.Top = objShp.Top + 20
    objShp.Left = objShp.Left + 20


    'コピーモード解除
    tmp.Offset(3).Select
    tmp.Copy
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    End
エラー:
    tmp.Select
    MsgBox ("エラーが発生しました。" + vbLf + Err.Description)
    Application.ScreenUpdating = True
End Sub