【VBA】エビデンスをエクセルに貼り付けるマクロ作ってみた。

はじめに

テストの時とか、一枚一枚キャプチャ撮ってエクセルぺたぺたするのが面倒くさくなり、
マクロ勉強ついでにエビデンスまとめる関数を作ってみました。

---

エビデンスまとめ

使い方
・VBAを組み込むエクセルのA1に保存したいファイル名を入力
・エビデンスをPrintScreen等で取得し、一箇所のフォルダにまとめておく
　→取得方法は何でも良い
　　自分はプリントスクリーンの保存場所をエクセルと同じ階層の
　　imagesフォルダに格納させるようにしました。
・エビデンスが保存し終わったら、関数実行してD3に入力したファイル名で、エビデンスがまとまったファイルを作成
　→ボタンに関数埋め込んだりすると使いやすい。ショートカット登録でも良いかも

Sub evidence()
Dim lngTop As Long              ' 画像貼り付け位置
Dim objFile As Object
Dim objFldr As FileSystemObject
Dim newBookName As String       ' 新しいブック名
Dim newBookPath As String       ' 格納先
Dim newBook     As Workbook     ' 新しいブック
Dim cpSheesName As String       ' コピー元のシート名
Dim cpShees     As Worksheet    ' コピーしたシート

    ' 新しいブック名、フルパスを先に保持
    newBookName = ActiveSheet.Range("A1").Value & ".xlsx"
    newBookPath = ThisWorkbook.Path & "\" & newBookName

    ' 新しいブックを作成するファイルが作成済かどうか確認
    If Dir(newBookPath) = "" Then
        ' 新しいシート作成
        Sheets.Add After:=Sheets(Sheets.Count)
        ' シート名変更
        Sheets(Sheets.Count).Name = "ファイル" & Sheets.Count - 1

        ' インスタンス生成
        Set objFldr = CreateObject("Scripting.FileSystemObject")

        lngTop = 10 '初期貼り付け位置
        ' キャプチャ貼付
        For Each objFile In objFldr.GetFolder(ThisWorkbook.Path & "\images").Files
            ActiveSheet.Shapes.AddPicture _
                    Filename:=objFile, _
                    LinkToFile:=False, _
                    SaveWithDocument:=True, _
                    Left:=20, _
                    Top:=lngTop, _
                    Width:=650, _
                    Height:=400

            lngTop = lngTop + 400 + 10
        Next

        cpSheesName = Worksheets(Worksheets.Count).Name

        ' ファイルがない場合は、新しくブック作成
        Set newBook = Workbooks.Add
        ' シート移動
        ThisWorkbook.Worksheets(cpSheesName).Move before:=ActiveWorkbook.Sheets(1)
        Set cpShees = ActiveSheet
        cpShees.Name = "エビデンス"

        ' 不要なシート削除
        Application.DisplayAlerts = False
        Worksheets("Sheet1").Delete
        Application.DisplayAlerts = True

        ' 新しいブックをVBAを実行したファイルと同じフォルダに保存
        newBook.SaveAs newBookPath
        ActiveWorkbook.Close

        ' 貼り付けた画像を削除
        objFldr.DeleteFile (ThisWorkbook.Path & "\images")
        Set objFldr = Nothing
    Else
        ' 既にファイルが存在する場合は、メッセージを表示して保存はしない
        MsgBox ("既に" & newBookName & "というファイルは存在します。")
    End If

    ' マクロのシートに戻って終了
    Sheets("マクロ").Select
End Sub

'おまけ
Sub sheetDel()
    Dim mySht As Worksheet
    With Application
        ' 警告や確認のメッセージを非表示に設定
        .DisplayAlerts = False
        ' シート名をチェックして、アクティブシートでなければ削除
        For Each mySht In Worksheets
            If mySht.Name <> "マクロ" Then mySht.Delete
        Next
        '設定を元に戻す
        .DisplayAlerts = True
    End With
End Sub

解説

解説は気が向いたら。。。

おわりに

とりあえず動くものは作れたけど、
もっとコンパクトにわかりやすくしたいなーと思いました。
すぐ試せるのも楽しいですね。
まだまだ勉強しなければっ