背景
皆さんは実験とかで撮った観察写真を有効に使えているでしょうか？
私は以前、「撮ったはいいけど、枚数が多すぎてまとめる気にならないなあ…」という感じで、苦労して取ったサンプルの観察写真のほんの一部しか後から見直していませんでした。
また、ほかの人が撮った(まとまっていない)観察写真をみても枚数が多すぎて一枚ずつ見る気にならず、結局うやむやにしてしまうことが少なくなかったです。
そんな問題に役立つかもしれない、画像ファイルのまとめ表を自動的につくるExcelシートの作成記録をここに記しておきます。
目的
・ファイル名さえルールに従って書けば、写真のまとめ作業をほぼ自動で行う仕組みをつくる
方針
・特定のルールに従い画像のファイル名をつけておく
・例:SAMPLE1_th10mm_110C_60min.jpg
・画像ファイルを取り込み、正規表現で属性を抽出
・属性から縦軸と横軸を選択し、マトリクス形式で画像を張り付ける
操作画面
画像ファイルを読み込んだ後、プレビューを確認しながら横軸縦軸を設定し、ボタンを押すとまとめ表が生成される、という操作感になっています。
黄色のセルはユーザーが自身の事情に合わせて入力する部分、水色の部分は関数が入力されいる部分です。
出力画面(テスト用画像なので画像の見た目が同じですが、画像下部のキャプションが違います)
実装
特定のルールに従い画像のファイル名をつけておく
正規表現で書けるようなルールで画像のファイル名を付けるようにします。
(サンプル名)_(正規表現で書けるような表記).jpgみたいな感じです。
今回はアンダーバーで区切るのも必須としてコードを書いています。
例:SAMPLE1_th10mm_110C_60min.jpg
このくらいのルールであれば普段からやっており、違和感はないのではないでしょうか。
ダッシュボードとなるワークシート
ダッシュボードとなるシートをまず準備します。
(上記画像と同じセル配置にすると以降のコードもコピペで動作します)
まずサンプル名に含まれる情報と、それに対応する正規表現を書いておきます。
(以降、「正規表現表」と呼びます。)
その下に、出力するまとめ表の横軸と縦軸を設定できるようなセルも用意しておきます。
ダッシュボード下部の水色のセル(G16)に、正規表現表の項目列を参照するTOROW関数を入力します。 これで、G16以右に正規表現表の項目が表示されます。
=TOROW(S3:S13,1) 'S3:S13は正規表現表の項目列
ダッシュボード上部の「プレビュー」部分の数式については後述します。
画像ファイルを取り込み、正規表現で属性を抽出
この仕組みのメイン機能の一つです。
・ボタンを押すとファイル選択ダイアログが立ち上がる
・選択されたファイルのファイル名から正規表現で情報が抽出される
・一覧表になってセルG17以下に出力される
モジュールに下記のコードを書き、サブルーチン「ファイル指定」を「画像ファイル選択」に割り当てています。
正規表現を使うため、VBEの参照設定でMicrosoft VBScript Regular Expressions 5.5を有効にしておく必要があります。
'配列のチェック、一覧表を入れる配列の再定義に使う
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以下)に選択されたファイルの情報とファイルパスが出力されます。
プレビューの準備
先ほど後述するとした、ダッシュボード上部のプレビュー画面部分の数式を入力します。
説明するのが難しいのですが、縦軸と横軸に対応する部分は
・縦軸と横軸の設定で設定された項目で
・画像ファイル一覧の対応する列から値を重複なしで抜き出し
・昇順または降順で並び替える
ということをしています。
=SORT(TOCOL(UNIQUE(OFFSET($G$17:$G$84,0,MATCH($T$17,$G$16:$P$16,0)-1),FALSE,FALSE),3),,$U$17)
=SORT(TOROW(UNIQUE(OFFSET($G$17:$G$84,0,MATCH($T$16,$G$16:$P$16,0)-1),FALSE,FALSE),3),,$U$16)
表のそれ以外(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までオートフィルすると意図した動作をするようになります。
つまりプレビュー画面として使えるようになります。
属性から縦軸と横軸を選択し、マトリクス形式で画像を張り付ける
次は、プレビュー画面のレイアウトの通り画像を張り付けていきます。
Excelで画像を張り付ける場合はWorkSheet.Shapes.AddPictureを使います。
具体的な手順
1.新しいワークシートを作成する
2.縦軸と横軸の設定
(ここからループ)
3.画像を張り付ける
4.画像の大きさを調節
5.セル内に張り付けられている枚数に応じて位置とセル幅を調整
(ループ終わり)
下記をまたモジュールに追加して、「マトリクス生成」をボタンに割り振ります。
(なおダッシュボードのシート名は"ダッシュボード"です)
'既に作ろうとしているシートと同じ名前のシートがあるか確認する関数
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
動作確認
もちろん、縦軸と横軸を変えていろいろな切り口のまとめ表を作成できます。
おわりに
以前、観察実験からまとめの報告までのスケジュールが完全に詰んでいた時があり、このExcelシートを家で作っておくことでなんとか事なきを得ました。この記事はそのシートの供養です。
機能が多すぎるので、伝えたいことがはっきりしない記事になってしまった感があります。要素ごとに分割して少しずつ記事にすべきでした。そのうちやりたいと思います。
一部でも誰かの役に立てば幸いです。