2020/01/26追記
※この記事のコードはバグだらけだったので以下の記事でデバッグしています！
エビデンス生成マクロがバグだらけだったのでデバッグしました
使い方は変わらないので、以下の記事は取扱説明書、もしくはデバッグ前の参照ソースコードとして読んでもらえると幸いです

エビデンスって取るのめんどくさいですよね

最近はテストを自動化するツールなんかもあったりするみたいですが、それでも導入できずに手動でテストをしていたり、その他の理由でエビデンスを取らなければならないという現場も少なくないのではないでしょうか

最近、VBAやGASの勉強を始めまして、エビデンスのエクセルファイルを作成する作業だけでもVBAで自動化出来ないのかと思っていたら案の定ありました。

Excelにエビデンスを張り付けるのを自動化した話。

クリップボードにある画像をエクセルに貼っていく感じですね。

ただ、これだとPCで撮ったエビデンスしか貼れません。

私のいる現場ではiOSやandroidの開発もあるので、ipadで撮ったスクリーンショットなども含めてエビデンスを作成したいと思い、勉強も兼ねて自分で作ってみました。

概要

任意のフォルダの直下にある画像ファイルの名前を読み取って、ブックの作成、シートの作成、エビデンスの貼り付けを自動で行います。

例えば、以下のように画像が保存してあるフォルダがあったとします。

このフォルダのpathを指定して、作成したいエビデンスの名前（今回はtest.xlsxとします）も指定すると、以下のようなエクセルファイルを作成します。

＜シート名：1＞

＜シート名：2＞

また、作成したエクセルファイルは画像があるpathの配下に保存されるので、マクロ実行後はこうなります。

上記にあるPNG,JPG以外にも、TIF,BMPなどにも対応しています。

画像ファイル名の-(ハイフン)より前をシート名として、シートを作成しています。
ハイフンより前の文字列が同じ画像をハイフンより後ろの文字列の順に同じシートに貼り付けます。

実際に実行するとこんな感じになります。

コード

実際に書いたコードは以下の通りです。変数名をつけるセンスが無さすぎるので、いい変数名などご教授いただける優しい方がいらっしゃいましたら是非コメントお願いします。
リファクタリングなどのご意見も大歓迎です。

標準モジュール

Sub generate_sheet(evidence_name As String, PATH_ As String)

    Dim wb As Workbook '新しいworkbookを作成
    Set wb = Workbooks.Add
    Dim f_name As String '挿入する画像の名前
    Dim f_name_arr() As String '画像名の配列
    Dim swap As String 'ソート用のスワップ
    Dim i As Long 'Forループ用
    Dim j As Long 'Forループ用
    Dim k As Long 'Forループ用
    Dim Sheet_name As String '生成するシート名
    Dim ws As Worksheet 'ワークシート
    Dim sheet_flg As Boolean '生成しようとするシート名と同じシートがあるかどうかのフラグ
    Dim pic_exist_flg As Boolean '対象のファイルがあるかどうか判別するフラグ
    Dim file_name_flg As Boolean '指定されたディレクトリ配下に保存しようとしたファイル名と同名のファイルがあるか検索
    Dim pic_top As Long '挿入する画像のTop位置
    Dim shp As Shape '画像を一時的に代入するshape
    
    wb.Activate '生成したworkbookをアクティブにする
    
    '選択したpathの配下にファイルが無かったら抜ける
    f_name = Dir(PATH_ & "\*")
    If f_name = "" Then
        MsgBox PATH_ & "にはファイルがありません。"
        Application.Quit
        Exit Sub
    End If
    
    '配列にファイル名を詰める
    Do
        i = i + 1
        ReDim Preserve f_name_arr(1 To i)
        f_name_arr(i) = f_name
        f_name = Dir
    Loop While f_name <> ""
    
    'ソート
    For j = 1 To i
        For k = i To j Step -1
            If StrComp(f_name_arr(j), f_name_arr(k)) = 1 Then
                swap = f_name_arr(j)
                f_name_arr(j) = f_name_arr(k)
                f_name_arr(k) = swap
            End If
        Next k
    Next j
    
    '画像を挿入する
    For j = 1 To i
        f_name = f_name_arr(j)
        If f_name = evidence_name & ".xlsx" Then
            file_name_flg = True
        End If
        
        '拡張子がtif,tiff,png,jpg.jpeg,bmpじゃなかったら飛ばす
        If UCase(Right(f_name, InStr(f_name, ".") - 1)) = UCase("png") Or _
            UCase(Right(f_name, InStr(f_name, ".") - 1)) = UCase("jpg") Or _
            UCase(Right(f_name, InStr(f_name, ".") - 1)) = UCase("jpeg") Or _
            UCase(Right(f_name, InStr(f_name, ".") - 1)) = UCase("bmp") Or _
            UCase(Right(f_name, InStr(f_name, ".") - 1)) = UCase("tif") Or _
            UCase(Right(f_name, InStr(f_name, ".") - 1)) = UCase("tiff") Then
            'ファイル名に-（ハイフン）がなかったら飛ばす
            If InStr(f_name, "-") <> 0 Then
                Sheet_name = Left(f_name, InStr(f_name, "-") - 1)  '-(ハイフン)の前の文字列をファイル名とする
                pic_exist_flg = True
            Else
                GoTo Skip
            End If
        Else
            GoTo Skip
        End If
        
        sheet_flg = False  'sheet_flgの初期化
        '既に同じ名前のワークシートがあったらワークシートを生成しない
        For Each ws In Worksheets
            If ws.Name = Sheet_name Then
                sheet_flg = True
                Exit For
            End If
        Next ws
        
        '同名のワークシートがなければ、一番後ろにワークシートを生成
        If sheet_flg = False Then
            Worksheets.Add after:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = Sheet_name
            pic_top = 20 '1枚目の画像は上から20px空ける
        End If
        
        '任意のワークシートに画像を挿入
        With Sheets(Sheet_name)
            Set shp = .Shapes.AddPicture( _
                Filename:=PATH_ & "\" & f_name, _
                linktofile:=False, _
                savewithdocument:=True, _
                Left:=20, _
                Top:=pic_top, _
                Width:=0, _
                Height:=0)
        End With
        
        With shp
            .ScaleHeight 1, msoTrue
            .ScaleWidth 1, msoTrue
            pic_top = pic_top + .Height + 20 '次の画像は20px空けたところに挿入する
        End With
Skip:
    Next
    
    If pic_exist_flg <> True Then
        MsgBox PATH_ & "には対象となるファイルがありません。"
        Application.Quit
        Exit Sub
    End If
    
    '最初から存在するシートを削除
    Application.DisplayAlerts = False
    Worksheets(1).Delete
    Application.DisplayAlerts = True
    
    '一枚目のシートをアクティブにする
    Worksheets(1).Activate
    
    If file_name_flg = True Then
        MsgBox PATH_ & "に同名のエクセルファイルがあります。" & vbCrLf & "ファイル名を変えて保存してください。"
    Else
        '指定したファイル名でエクセルファイルを保存
        wb.SaveAs _
        Filename:=PATH_ & "\" & evidence_name & ".xlsx", _
        FileFormat:=xlOpenXMLWorkbook
    End If
    
    'マクロを実行したエクセルファイルを閉じる
    Workbooks("evidence.xlsm").Close
End Sub

フォーム

Private Sub CommandButton1_Click()
    'ユーザーフォームのボタンを押したらシートを生成する関数を呼び出す
    Call generate_sheet(TextBox1.Text, TextBox2.Text)
    Unload Me
End Sub

Private Sub UserForm_Initialize()

    'ユーザーフォームが出ている間はエクセルファイルを見せない
    Application.Visible = False
    
    'ユーザーフォームのサイズ指定
    Application.WindowState = xlMaximized
    Me.Height = 220
    Me.Width = 450
    Me.Zoom = 100
End Sub

Private Sub UserForm_Terminate()
    'ユーザーフォームが閉じたらエクセルファイルを見せる
    Application.Visible = True
End Sub

ワークシート

Private Sub Workbook_Open()
    'ワークシートを開いた時にユーザーフォームを出す
    path_input.Show
End Sub

ユーザーフォームはこんな感じです。

FilenameのテキストボックスがTextBox1で、PathのテキストボックスがTextBox2になってます。

流れの説明

まずワークシートが開かれた時にユーザーフォームが表示されます。

Private Sub Workbook_Open()
    'ワークシートを開いた時にユーザーフォームを出す
    path_input.Show
End Sub

そのユーザーフォームに作成したいエクセルファイルの名前と、貼り付けたい画像が保存してあるpathを入力して「エビデンス生成」のボタンを押すと、テキストボックスからそれぞれを取得して、関数を走らせます。

Private Sub CommandButton1_Click()
    'ユーザーフォームのボタンを押したらシートを生成する関数を呼び出す
    Call generate_sheet(TextBox1.Text, TextBox2.Text)
    Unload Me
End Sub

呼び出された関数で変数を定義するのと一緒に新しいワークブックを作成します。

    Dim wb As Workbook '新しいworkbookを作成
    Set wb = Workbooks.Add
    Dim f_name As String '挿入する画像の名前
    Dim f_name_arr() As String '画像名の配列
    Dim swap As String 'ソート用のスワップ
    Dim i As Long 'Forループ用
    Dim j As Long 'Forループ用
    Dim k As Long 'Forループ用
    Dim Sheet_name As String '生成するシート名
    Dim ws As Worksheet 'ワークシート
    Dim sheet_flg As Boolean '生成しようとするシート名と同じシートがあるかどうかのフラグ
    Dim pic_exist_flg As Boolean '対象のファイルがあるかどうか判別するフラグ
    Dim file_name_flg As Boolean '指定されたディレクトリ配下に保存しようとしたファイル名と同名のファイルがあるか検索
    Dim pic_top As Long '挿入する画像のTop位置
    Dim shp As Shape '画像を一時的に代入するshape

指定したpathの配下にファイルがなかったら処理を終了します。

    '選択したpathの配下にファイルが無かったら抜ける
    f_name = Dir(PATH_ & "\*")
    If f_name = "" Then
        MsgBox PATH_ & "にはファイルがありません。"
        Application.Quit
        Exit Sub
    End If

配列に指定したpath配下のファイルの名前を詰めていきます。ここではバリデーションをせずにとりあえず全部詰めます（後で使うので）。

    '配列にファイル名を詰める
    Do
        i = i + 1
        ReDim Preserve f_name_arr(1 To i)
        f_name_arr(i) = f_name
        f_name = Dir
    Loop While f_name <> ""

後の処理の都合でファイルが名前順に並んでくれないと困るので、ソートします。（おそらくフォルダ内で名前順にソートされているとは思うのですが）

    'ソート
    For j = 1 To i
        For k = i To j Step -1
            If StrComp(f_name_arr(j), f_name_arr(k)) = 1 Then
                swap = f_name_arr(j)
                f_name_arr(j) = f_name_arr(k)
                f_name_arr(k) = swap
            End If
        Next k
    Next j

ソートが終わったらいよいよシートを作成しつつ、画像を貼り付けます。
ここでバリデーションと保存しようとしているエクセルファイルの名前が既に存在するものではないかのチェックを行います。

バリデーションチェックを抜けたら、シート名となるハイフンより前の文字列を取り出します。

    '画像を挿入する
    For j = 1 To i
        f_name = f_name_arr(j)
        If f_name = evidence_name & ".xlsx" Then
            file_name_flg = True
        End If
        
        '拡張子がtif,tiff,png,jpg.jpeg,bmpじゃなかったら飛ばす
        If UCase(Right(f_name, InStr(f_name, ".") - 1)) = UCase("png") Or _
            UCase(Right(f_name, InStr(f_name, ".") - 1)) = UCase("jpg") Or _
            UCase(Right(f_name, InStr(f_name, ".") - 1)) = UCase("jpeg") Or _
            UCase(Right(f_name, InStr(f_name, ".") - 1)) = UCase("bmp") Or _
            UCase(Right(f_name, InStr(f_name, ".") - 1)) = UCase("tif") Or _
            UCase(Right(f_name, InStr(f_name, ".") - 1)) = UCase("tiff") Then
            'ファイル名に-（ハイフン）がなかったら飛ばす
            If InStr(f_name, "-") <> 0 Then
                Sheet_name = Left(f_name, InStr(f_name, "-") - 1)  '-(ハイフン)の前の文字列をファイル名とする
                pic_exist_flg = True
            Else
                GoTo Skip
            End If
        Else
            GoTo Skip
        End If

ワークシートの名前をチェックし、作成しているワークシートと同名のものがなければ作成し、そのワークシートの一番上に画像を貼り付けます。

同名のワークシートがある場合はそのワークシートで貼り付けてある画像の下に新たな画像を貼り付けます。

この時にファイルがソートされていないと、画像を挿入する位置が変になるんです。

        sheet_flg = False  'sheet_flgの初期化
        '既に同じ名前のワークシートがあったらワークシートを生成しない
        For Each ws In Worksheets
            If ws.Name = Sheet_name Then
                sheet_flg = True
                Exit For
            End If
        Next ws
        
        '同名のワークシートがなければ、一番後ろにワークシートを生成
        If sheet_flg = False Then
            Worksheets.Add after:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = Sheet_name
            pic_top = 20 '1枚目の画像は上から20px空ける
        End If
        
        '任意のワークシートに画像を挿入
        With Sheets(Sheet_name)
            Set shp = .Shapes.AddPicture( _
                Filename:=PATH_ & "\" & f_name, _
                linktofile:=False, _
                savewithdocument:=True, _
                Left:=20, _
                Top:=pic_top, _
                Width:=0, _
                Height:=0)
        End With
        
        With shp
            .ScaleHeight 1, msoTrue
            .ScaleWidth 1, msoTrue
            pic_top = pic_top + .Height + 20 '次の画像は20px空けたところに挿入する
        End With
Skip:
    Next

すべての画像を貼り終わったらその後の処理です。
まず、指定したpathの配下の画像がバリデーションでひっかかってしまった場合（画像ファイルでない、ファイル名にハイフンが入っていない）、アラートを表示させて処理を終了します。

    If pic_exist_flg <> True Then
        MsgBox PATH_ & "には対象となるファイルがありません。"
        Application.Quit
        Exit Sub
    End If

一枚でも新しいワークシートが作成できているのであれば、最初からあるワークシートは不要なので、削除して1枚目のワークシートをアクティブにします。

    '最初から存在するシートを削除
    Application.DisplayAlerts = False
    Worksheets(1).Delete
    Application.DisplayAlerts = True
    
    '一枚目のシートをアクティブにする
    Worksheets(1).Activate

保存しようとしているpath配下に同盟のエクセルファイルが存在する場合は、保存は行わず、メッセージボックスを表示させます。
同名のエクセルファイルが無い場合は保存します。

その後、マクロを実行しているエクセルファイルを閉じて終了です。

    If file_name_flg = True Then
        MsgBox PATH_ & "に同名のエクセルファイルがあります。" & vbCrLf & "ファイル名を変えて保存してください。"
    Else
        '指定したファイル名でエクセルファイルを保存
        wb.SaveAs _
        Filename:=PATH_ & "\" & evidence_name & ".xlsx", _
        FileFormat:=xlOpenXMLWorkbook
    End If
    
    'マクロを実行したエクセルファイルを閉じる
    Workbooks("evidence.xlsm").Close
End Sub

やってみて

最初はvbaで別のものを作ろうとしていたのですが、触ってたらエビデンスってvbaでなんとかなんないの？っていう思いつきから作ってみた偶然の産物です。

いざ始めてみたらコーディングは1日で出来たので、vbaって意外に簡単にできるんだなっていうのが率直な感想ですね。

ただ、まだまだペーペーのエンジニアなので、色んな人からフィードバックもらいたいなと思ってQiitaに投稿してみました！

是非コメントで色々ご意見いただけると幸いです！

追記

【備忘録】Excel2010以降のVBAで画像の実体を挿入する

こちらの記事にあるように、「ActiveSheet.Pictures.Insert」だと画像がリンク貼り付けになっちゃうので、作成したエビデンスを人に渡したりすると画像が見れない！っていうとんでもないバグが見つかりました。

完全に考慮不足…

ということで、「ActiveSheet.Pictures.Insert」から「ActiveSheet.Shapes.AddPicture」に直しました。