大量の観察写真から、任意のレイアウトのまとめ表を作る[Excel VBA]

## 背景
皆さんは実験とかで撮った観察写真を有効に使えているでしょうか？
私は以前、「撮ったはいいけど、枚数が多すぎてまとめる気にならないなあ…」という感じで、苦労して取ったサンプルの観察写真のほんの一部しか後から見直していませんでした。
また、ほかの人が撮った(まとまっていない)観察写真をみても枚数が多すぎて一枚ずつ見る気にならず、結局うやむやにしてしまうことが少なくなかったです。
そんな問題に役立つかもしれない、画像ファイルのまとめ表を自動的につくるExcelシートの作成記録をここに記しておきます。

![image.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/3471244/7a4a9564-eec4-c99f-7502-e9ebdf157fd5.png)


## 目的
・ファイル名さえルールに従って書けば、写真のまとめ作業をほぼ自動で行う仕組みをつくる

## 方針

・特定のルールに従い画像のファイル名をつけておく
　・例:SAMPLE1_th10mm_110C_60min.jpg
・画像ファイルを取り込み、正規表現で属性を抽出
・属性から縦軸と横軸を選択し、マトリクス形式で画像を張り付ける
![image.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/3471244/74eec775-e7d3-db73-3c39-e13a07376af4.png)

## 操作画面
画像ファイルを読み込んだ後、プレビューを確認しながら横軸縦軸を設定し、ボタンを押すとまとめ表が生成される、という操作感になっています。
黄色のセルはユーザーが自身の事情に合わせて入力する部分、水色の部分は関数が入力されいる部分です。
![image.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/3471244/f1a5b99d-b200-1ff0-f6b1-87603c8ec3e5.png)

出力画面(テスト用画像なので画像の見た目が同じですが、画像下部のキャプションが違います)
![image.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/3471244/91496932-6258-c0d7-dc7b-7a1b4657eeed.png)


## 実装
### 特定のルールに従い画像のファイル名をつけておく

正規表現で書けるようなルールで画像のファイル名を付けるようにします。
(サンプル名)_(正規表現で書けるような表記).jpgみたいな感じです。
今回はアンダーバーで区切るのも必須としてコードを書いています。
例:SAMPLE1_th10mm_110C_60min.jpg
このくらいのルールであれば普段からやっており、違和感はないのではないでしょうか。

### ダッシュボードとなるワークシート
ダッシュボードとなるシートをまず準備します。
(上記画像と同じセル配置にすると以降のコードもコピペで動作します)
<br>
まずサンプル名に含まれる情報と、それに対応する正規表現を書いておきます。
(以降、「正規表現表」と呼びます。)
その下に、出力するまとめ表の横軸と縦軸を設定できるようなセルも用意しておきます。
![image.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/3471244/42be4f89-c489-33a7-be36-47962a0f048d.png)

<br>
ダッシュボード下部の水色のセル(G16)に、正規表現表の項目列を参照するTOROW関数を入力します。
これで、G16以右に正規表現表の項目が表示されます。

``` vb:セルG16
=TOROW(S3:S13,1) 'S3:S13は正規表現表の項目列
```
![image.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/3471244/eedda2ed-22ae-b823-b6ce-16f59b0a4613.png)

<br>

ダッシュボード上部の「プレビュー」部分の数式については後述します。

### 画像ファイルを取り込み、正規表現で属性を抽出
この仕組みのメイン機能の一つです。
・ボタンを押すとファイル選択ダイアログが立ち上がる
・選択されたファイルのファイル名から正規表現で情報が抽出される
・一覧表になってセルG17以下に出力される
![image.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/3471244/69441c01-5ad9-4943-0147-b9d39019cac2.png)

モジュールに下記のコードを書き、サブルーチン「ファイル指定」を「画像ファイル選択」に割り当てています。
正規表現を使うため、VBEの参照設定でMicrosoft VBScript Regular Expressions 5.5を有効にしておく必要があります。
``` vb:画像ファイル選択
'配列のチェック、一覧表を入れる配列の再定義に使う
Function Is_correct_array(ByVal arrs As Variant) 
    Dim a As Long
    
    On Error GoTo err
    a = UBound(arrs)

    'エラー番号から、配列の状態を判別
err:
    If err.Number = 9 Or err.Number = 13 Then
        Is_correct_array = False
    Else
        Is_correct_array = True
    End If
    
End Function


 '配列のチェック、一覧表を入れる配列の再定義に使う
Function IsArrayEmpty(ByVal arrs As Variant)
    Dim arr As Variant
    
    '配列が定義されているか
    If Not Is_correct_array(arrs) Then
        Debug.Print "配列が定義されていません"
        IsArrayEmpty = True
        Exit Function
    End If
    
    IsArrayEmpty = True
    '一つでも要素がEmptyではない場合はFalseにする
    For Each arr In arrs
        If TypeName(arr) <> "Empty" Then
            IsArrayEmpty = False
            Exit For
        End If
    Next
End Function

'アンダースコアで分割したときの最初の部分を抜き出す。サンプル名取得に使う
Function ExtractFirstChunk(str As String) As String
    Dim chunks() As String
    
    ' アンダースコアで文字列を分割
    chunks = Split(str, "_")
    
    ' 最初の文字列を返す
    ExtractFirstChunk = chunks(0)
End Function

'ファイルパス取得用に、文字列を\で分割した時の末尾の部分を抜き出すのに使う
Function ExtractLastChunk(str As String) As String
    Dim chunks() As String
    
    ' \で文字列を分割
    chunks = Split(str, "\")
    
    ' 最後の文字列を返す
    ExtractLastChunk = chunks(UBound(chunks))
End Function

'正規表現、参照設定でMicrosoft VBScript Regular Expressions 5.5を有効にしておく
Function ExtractMatchedText(sourceText As String, pattern As String) As String
    Dim regex As RegExp
    Dim matches As Object
    Dim match As Object
    Dim extractedText As String
    
    ' 正規表現オブジェクトを作成
    Set regex = CreateObject("VBScript.RegExp")
    
    ' 正規表現パターンを設定
    regex.pattern = pattern
    '大文字と小文字を区別しない
    regex.IgnoreCase = True
    
    ' ソーステキストからマッチする部分を取得
    Set matches = regex.Execute(sourceText)
    
    ' 最初のマッチした部分を抜き出す
    If matches.Count > 0 Then
        Set match = matches.Item(0)
        extractedText = match.Value
    Else
        extractedText = ""
    End If
    
    ' 抜き出した部分を返す
    ExtractMatchedText = extractedText
End Function

'抜き出された画像の情報を既存の配列に追加する関数
Function AddRowTo2DArray(arr As Variant, NewRow As Variant, ContentNum As Integer) As Variant
    Dim numRows As Long
    Dim numCols As Long
    Dim i As Long
    Dim NewArr() As Variant
    If IsArrayEmpty(arr) Then
        numRows = 0
        numCols = ContentNum + 1
    Else
        ' 既存の行数と列数を取得
        numRows = UBound(arr, 1)
        numCols = UBound(arr, 2)
    End If
    ' 新しい行を追加するために既存の配列のサイズを再定義
    ReDim NewArr(1 To numRows + 1, 1 To numCols)
    '既存の配列のデータを移す
    If numRows >= 1 Then
    For i = 1 To numRows
    For j = 1 To numCols
        NewArr(i, j) = arr(i, j)
    Next j
    Next i
    End If
    
    ' 新しい行を配列に追加
    For i = 1 To numCols
        NewArr(numRows + 1, i) = NewRow(i)
    Next i
    
    ' 更新された配列を返す
    AddRowTo2DArray = NewArr
End Function

'メインの実行部分
Sub ファイル指定()
    Dim FileDialog As FileDialog
    Dim SelectedFilesPaths() As String
    Dim FileCount As Integer
    Dim i, j, k As Integer
    Dim FileName As String
    Dim SampleName As String
    Dim ContentNum As Integer
    Dim InfoArr() As Variant
    Dim NewRow() As Variant
    Dim ReStr As String
    
    
    
    ' ファイルダイアログを作成
    Set FileDialog = Application.FileDialog(msoFileDialogFilePicker)
    
    ' ダイアログの設定
    With FileDialog
        .AllowMultiSelect = True ' 複数のファイルを選択可能にする
        .Title = "複数のファイルを選択してください"
        
        ' ダイアログを表示
        If .Show = -1 Then
            ' 選択されたファイル数を取得
            FileCount = .SelectedItems.Count
            
            ' 選択されたファイルのパスを配列に格納
            ReDim SelectedFilesPaths(1 To FileCount)
            For i = 1 To FileCount
                SelectedFilesPaths(i) = .SelectedItems(i)
            Next i
            
            ' 各ファイルについて情報を抜き出す
            For i = 1 To FileCount
                'ファイルパス記載
                Cells(16 + i, 17).Value = SelectedFilesPaths(i)
                'ファイル名取得
                FileName = ExtractLastChunk(SelectedFilesPaths(i))
                'サンプル名取得
                SampleName = ExtractFirstChunk(FileName)
                
                '正規表現によるサンプル名、各項目取得
                ContentNum = WorksheetFunction.CountA(Range("S4:S13"))'正規表現表の「項目」列
                ReDim NewRow(1 To ContentNum + 1)
                NewRow(1) = SampleName
                k = 2

                 For j = 4 To 13
                    If Cells(j, 19).Value <> "" Then
                        ReStr = CStr(Cells(j, 20).Value)
                        NewRow(k) = ExtractMatchedText(FileName, ReStr)
                        k = k + 1
                    End If
                Next j

                '既存の配列と統合
                InfoArr = AddRowTo2DArray(InfoArr, NewRow, ContentNum)

            Next i
            
            
            
            Dim iRow, iCol, iRowMax, iColMax As Long
                           
            ' １次元目の要素数を取得
            iRowMax = UBound(InfoArr, 1) - LBound(InfoArr, 1) + 1
            ' ２次元目の要素数を取得
            iColMax = UBound(InfoArr, 2) - LBound(InfoArr, 2) + 1
            

            ' Rangeオブジェクトで開始セルから貼り付ける
            Range("G17").Resize(iRowMax, iColMax).Value = InfoArr
        End If
    End With
    
    ' ファイルダイアログを解放
    Set FileDialog = Nothing
End Sub

```

ダッシュボード下部(セルG17以下)に選択されたファイルの情報とファイルパスが出力されます。
![image.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/3471244/bee9ed4a-f97d-314e-b52e-f25f8b7c4621.png)

### プレビューの準備
先ほど後述するとした、ダッシュボード上部のプレビュー画面部分の数式を入力します。

説明するのが難しいのですが、縦軸と横軸に対応する部分は
・縦軸と横軸の設定で設定された項目で
・画像ファイル一覧の対応する列から値を重複なしで抜き出し
・昇順または降順で並び替える
ということをしています。
```vb:セルH4(縦軸)
=SORT(TOCOL(UNIQUE(OFFSET($G$17:$G$84,0,MATCH($T$17,$G$16:$P$16,0)-1),FALSE,FALSE),3),,$U$17)

```
![image.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/3471244/23d4013f-39a8-5233-4c27-a8d4daceb669.png)

```vb:セルI3(横軸)
=SORT(TOROW(UNIQUE(OFFSET($G$17:$G$84,0,MATCH($T$16,$G$16:$P$16,0)-1),FALSE,FALSE),3),,$U$16)
```
![image.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/3471244/46a5b0bf-0f8b-fe71-bb6d-5fe17c0ed8d8.png)


表のそれ以外(I4より右下)の部分も簡単な説明が難しいですが、
・表内の座標に対応する縦軸と横軸の値で、画像ファイル一覧を検索
・そのようなファイルがあれば〇
・ない場合は空白
という処理をしています。
```vb:セルI4
=IFNA(IF(AND(MATCH($H4&I$3,OFFSET($G$17:$G$84,0,MATCH($T$17,$G$16:$P$16,0)-1)&OFFSET($G$17:$G$84,0,MATCH($T$16,$G$16:$P$16,0)-1),0)>0,$H4<>""),"〇",""),"")
```
これをQ13までオートフィルすると意図した動作をするようになります。
つまりプレビュー画面として使えるようになります。

![image.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/3471244/36cd262a-b097-d55c-8f8b-7d39ca06f0ad.png)


### 属性から縦軸と横軸を選択し、マトリクス形式で画像を張り付ける
次は、プレビュー画面のレイアウトの通り画像を張り付けていきます。
Excelで画像を張り付ける場合はWorkSheet.Shapes.AddPictureを使います。
<br>
具体的な手順
1.新しいワークシートを作成する
2.縦軸と横軸の設定
　(ここからループ)
3.画像を張り付ける
4.画像の大きさを調節
5.セル内に張り付けられている枚数に応じて位置とセル幅を調整
　(ループ終わり)

<br>
下記をまたモジュールに追加して、「マトリクス生成」をボタンに割り振ります。

(なおダッシュボードのシート名は"ダッシュボード"です)

 ```vb:マトリクス生成
'既に作ろうとしているシートと同じ名前のシートがあるか確認する関数
 Function ExistsSheet(ByVal bookName As String)
    Dim ws As Variant
    For Each ws In Sheets
        If LCase(ws.Name) = LCase(bookName) Then
            ExistsSheet = True ' 存在する
            Exit Function
        End If
    Next

    ' 存在しない
    ExistsSheet = False
End Function

'シートの作成
Function CreateSheet(SheetName As String) As String
    Dim renban As Long
    
    Dim NewWorkSheet As Worksheet
    Set NewWorkSheet = Worksheets.Add(, Worksheets(Worksheets.Count))
    
    '既に作ろうとしているシートと同じ名前のシートがあるか確認
    If ExistsSheet(Left(SheetName, 31)) = False Then
         NewWorkSheet.Name = Left(SheetName, 31) '32文字以上のシート名はエラーが出るので回避
    Else
        NewWorkSheet.Name = Left(SheetName, 25) & Format(Time(), "hhmmss")
    End If
    
    CreateSheet = NewWorkSheet.Name
    
End Function

'画像の挿入
Function InsertAndResizeImage(imgPath As String, i As Long, j As Long, cellWidth As Double, cellHeight As Double, SheetName As String) As Boolean
    Dim ws As Worksheet
    Dim img As Shape
    Dim imgWidth As Double, imgHeight As Double
    Dim ratio As Double
    
    On Error Resume Next ' エラーハンドリングを無効化

    ' シートを選択
    Set ws = ThisWorkbook.Worksheets(SheetName)
    
    ' 画像を挿入
    Set img = ws.Shapes.AddPicture( _
                FileName:=imgPath, _
                LinkToFile:=msoFalse, _
                SaveWithDocument:=msoTrue, _
                Left:=0, _
                Top:=0, _
                width:=-1, _
                height:=-1)


    ' 画像のサイズを取得
    imgWidth = img.width
    imgHeight = img.height
    
    ' 縮小倍率を計算
    ratio = Application.WorksheetFunction.Min(cellWidth / imgWidth, cellHeight / imgHeight)
    
    ' 画像を縮小
    img.width = imgWidth * ratio
    img.height = imgHeight * ratio
    
    'セルの幅を調整
    If ws.Cells(i, j).Value = WorksheetFunction.Max(ws.Range("B2:AA1000").Columns(j - 1)) Then
        ws.Columns(j).ColumnWidth = (ws.Cells(i, j).Value + 1) * cellWidth * ratio * (57 / 180) 'excelは高さと幅の単位が違うので補正
    End If


    
    ' 画像を指定したセルに移動
    img.Top = ws.Cells(i, j).Top
    img.Left = ws.Cells(i, j).Left + img.width * ws.Cells(i, j).Value
    
     
    'セルの値(セル内の画像の枚数)を1増加
     ws.Cells(i, j).Value = ws.Cells(i, j).Value + 1

    
    InsertAndResizeImage = True
End Function


Sub マトリクス作成()

'G17:画像ファイル一覧の先頭セル T16:横軸の項目 T17:縦軸の項目
Dim NewSheetName As String
    NewSheetName = CreateSheet(Range("G17").Value & "他_" & Range("T16").Value & "_" & Range("T17").Value) 'シート作成
Dim height As Double 'セル高さ
Dim width As Double 'セル幅

'お好みで画像の大きさを調整
height = 90
width = height * 4 / 3
    
    
    '縦横軸の設定、セル高さを調整
    With Worksheets(NewSheetName)
        .Range("B1:J1").Value = Worksheets("ダッシュボード").Range("I3:Q3").Value
        .Range("A2:A11").Value = Worksheets("ダッシュボード").Range("H4:H13").Value

        For i = 2 To 11
            If .Cells(i, 1).Value <> 0 Then
                .Rows(i).RowHeight = height
            End If
        Next i
    
    End With
    
    
    k = 17
    Do While Worksheets("ダッシュボード").Cells(k, 7) <> ""  '各画像についてループ処理
        
    With Worksheets("ダッシュボード")
        xAxisvalue = .Range(.Cells(k, 7).Address).Offset(0, WorksheetFunction.match(.Range("T16").Value, .Range("G16:P16"), 0) - 1) 'ファイル名に対応するx軸とy軸の値を取得
        yAxisvalue = .Range(.Cells(k, 7).Address).Offset(0, WorksheetFunction.match(.Range("T17").Value, .Range("G16:P16"), 0) - 1)
        
        xAxis = WorksheetFunction.match(xAxisvalue, .Range("I3:Q3"), 0) 'x軸とy軸の値に対応するセル座標を取得
        yAxis = WorksheetFunction.match(yAxisvalue, .Range("H4:H13"), 0)

        
     
       

    ' 「ファイルパス」列を参照し、画像を挿入
    If InsertAndResizeImage(.Cells(k, 17).Value, yAxis + 1, xAxis + 1, width, height, NewSheetName) Then

    Else
        MsgBox "何かエラーが起きました", vbExclamation
    End If
    
    End With
     
     k = k + 1
    Loop
    MsgBox "終了しました"
End Sub

```

動作確認
![image.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/3471244/f002fcbe-bf3c-f436-fcdd-692514f071aa.png)
![image.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/3471244/a3f08192-56c5-c6d2-8075-dde45de70491.png)
もちろん、縦軸と横軸を変えていろいろな切り口のまとめ表を作成できます。
![image.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/3471244/3418b574-f3b1-f438-afa1-7162fc86d992.png)


## おわりに
以前、観察実験からまとめの報告までのスケジュールが完全に詰んでいた時があり、このExcelシートを家で作っておくことでなんとか事なきを得ました。この記事はそのシートの供養です。
機能が多すぎるので、伝えたいことがはっきりしない記事になってしまった感があります。要素ごとに分割して少しずつ記事にすべきでした。そのうちやりたいと思います。
一部でも誰かの役に立てば幸いです。