写真台帳をExcelで作るとき、最初につまずきやすいのが写真の貼り付け作業です。
写真を1枚ずつ挿入し、サイズを合わせ、枠の中に収め、横や下にファイル名やコメントを入れる。数枚なら手作業でも対応できますが、現場写真、工事写真、点検写真が何十枚もあると、かなり面倒です。
しかも、手作業で貼り付けると、写真サイズが揃わなかったり、枠から少しはみ出したり、印刷やPDF出力の段階で位置がずれたりします。
この記事では、写真台帳をExcelで作るときの基本構成と、指定フォルダ内の写真をExcel上の写真枠へ順番に貼り付ける、すぐ使えるVBAコードを紹介します。
コードはそのまま試せる形にしていますが、実際に使うテンプレート、結合セル、印刷範囲、写真枠の位置に合わせて調整が必要です。
Excel写真台帳の基本構成
Excelで写真台帳を作る場合、よくある構成は次のようなものです。
- 写真枠
- 写真番号
- ファイル名
- 写真タイトル
- コメント欄
- 備考欄
- ページ番号
- 印刷範囲
- 余白設定
1ページに写真を何枚入れるかは、用途によって変わります。3枚台帳、6枚台帳、8枚台帳などがあります。
工事写真や施工写真では、1枚ごとに写真タイトルやコメントを付けることが多く、点検写真では損傷内容や確認内容を併記することもあります。
重要なのは、写真の見た目だけでなく、写真と説明文の対応を崩さないことです。
写真だけが正しく貼られていても、コメントが1行ずれていたら、台帳としては危険です。
手作業で貼り付けると起きやすい問題
Excelに写真を手作業で貼ると、次のような問題が起きやすくなります。
- 写真サイズが揃わない
- 写真が枠からはみ出す
- 写真の縦横比が崩れる
- 写真の位置が少しずつずれる
- 写真とファイル名の対応が分からなくなる
- コメント欄が写真とずれる
- 印刷すると写真が切れる
- PDF出力するとレイアウトが崩れる
画面上ではきれいに見えていても、印刷プレビューやPDF出力では位置が変わって見えることがあります。Excelで写真台帳を作るときに画像がずれる原因については、別記事で整理しています。
また、PDF出力時のレイアウト崩れも確認が必要です。提出前には、Excel画面だけでなく、印刷プレビューとPDF出力後の状態を確認するのが安全です。
VBAで効率化できる範囲
VBAを使うと、写真台帳作成のうち、次のような作業を効率化できます。
- 写真フォルダを選択する
- jpg / jpeg / png を順番に取得する
- 指定した写真枠へ貼り付ける
- 縦横比を保ったまま枠内に収める
- 写真を枠の中央に配置する
- ファイル名を所定セルへ入れる
- 既存画像を削除して貼り直す
一方で、VBAだけで完結させない方がよい部分もあります。
たとえば、写真の選定、コメントの妥当性、提出様式との整合、工事写真としての必要性、発注者指定様式への適合などは、人間が確認する必要があります。
VBAは、あくまで貼り付けや整形を補助する道具です。
すぐ使えるVBAコード：フォルダ内写真を写真枠へ順番に貼る
ここから、指定フォルダ内の写真を、Excelシート上の写真枠へ順番に貼り付けるVBAコードを紹介します。
このサンプルでは、写真台帳 シートに6枚分の写真枠を想定しています。貼付先のセル範囲はコード内の photoRanges で指定しています。
実際のテンプレートに合わせる場合は、B4:H15 などのセル範囲を書き換えて使ってください。
以下のコードは、写真台帳作成を補助するためのサンプルです。利用するExcelのバージョン、シート構成、結合セル、印刷範囲、画像サイズ、余白設定によって調整が必要になる場合があります。
実務ファイルで実行する前に、必ずファイルのバックアップを取ってください。まずはテスト用ブックとテスト用写真で動作確認してください。マクロを使うには、Excel側でマクロを有効化する必要があります。
Option Explicit
Sub 写真台帳へ写真を順番に貼り付ける()
Dim ws As Worksheet
Dim folderPath As String
Dim files() As String
Dim fileCount As Long
Dim i As Long
Dim frameIndex As Long
Dim pageIndex As Long
Dim rowOffset As Long
Dim photoRanges As Variant
Dim fileNameCells As Variant
Const PAGE_ROW_HEIGHT As Long = 45
folderPath = SelectPhotoFolder()
If folderPath = "" Then Exit Sub
files = GetPhotoFiles(folderPath, fileCount)
If fileCount = 0 Then
MsgBox "対象フォルダに jpg / jpeg / png ファイルが見つかりませんでした。", vbExclamation
Exit Sub
End If
SortStringArray files, fileCount
Set ws = GetOrCreateSheet("写真台帳")
photoRanges = Array("B4:H15", "J4:P15", _
"B19:H30", "J19:P30", _
"B34:H45", "J34:P45")
fileNameCells = Array("B16", "J16", _
"B31", "J31", _
"B46", "J46")
DeletePhotoShapes ws, "PHOTO_"
Application.ScreenUpdating = False
For i = 1 To fileCount
frameIndex = (i - 1) Mod (UBound(photoRanges) + 1)
pageIndex = Int((i - 1) / (UBound(photoRanges) + 1))
rowOffset = pageIndex * PAGE_ROW_HEIGHT
InsertPictureFitToRange _
ws:=ws, _
picturePath:=folderPath & "\" & files(i), _
targetRange:=OffsetRange(ws.Range(photoRanges(frameIndex)), rowOffset), _
shapeName:="PHOTO_" & Format$(i, "0000")
OffsetRange(ws.Range(fileNameCells(frameIndex)), rowOffset).Value = files(i)
Next i
Application.ScreenUpdating = True
MsgBox "写真を貼り付けました。" & vbCrLf & _
"貼付枚数: " & fileCount & " 枚" & vbCrLf & _
"印刷範囲とPDF出力結果を確認してください。", vbInformation
End Sub
Private Function SelectPhotoFolder() As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "写真フォルダを選択してください"
.AllowMultiSelect = False
If .Show <> -1 Then
SelectPhotoFolder = ""
Else
SelectPhotoFolder = .SelectedItems(1)
End If
End With
End Function
Private Function GetPhotoFiles(ByVal folderPath As String, ByRef fileCount As Long) As String()
Dim tempFiles() As String
Dim fileName As String
Dim ext As String
ReDim tempFiles(1 To 1)
fileCount = 0
fileName = Dir(folderPath & "\*.*")
Do While fileName <> ""
ext = LCase$(Mid$(fileName, InStrRev(fileName, ".") + 1))
If ext = "jpg" Or ext = "jpeg" Or ext = "png" Then
fileCount = fileCount + 1
ReDim Preserve tempFiles(1 To fileCount)
tempFiles(fileCount) = fileName
End If
fileName = Dir()
Loop
GetPhotoFiles = tempFiles
End Function
Private Sub SortStringArray(ByRef arr() As String, ByVal itemCount As Long)
Dim i As Long
Dim j As Long
Dim tmp As String
If itemCount <= 1 Then Exit Sub
For i = 1 To itemCount - 1
For j = i + 1 To itemCount
If StrComp(arr(i), arr(j), vbTextCompare) > 0 Then
tmp = arr(i)
arr(i) = arr(j)
arr(j) = tmp
End If
Next j
Next i
End Sub
Private Function GetOrCreateSheet(ByVal sheetName As String) As Worksheet
Dim ws As Worksheet
On Error Resume Next
Set ws = ThisWorkbook.Worksheets(sheetName)
On Error GoTo 0
If ws Is Nothing Then
Set ws = ThisWorkbook.Worksheets.Add
ws.Name = sheetName
End If
Set GetOrCreateSheet = ws
End Function
Private Function OffsetRange(ByVal baseRange As Range, ByVal rowOffset As Long) As Range
Set OffsetRange = baseRange.Offset(rowOffset, 0)
End Function
Private Sub InsertPictureFitToRange(ByVal ws As Worksheet, _
ByVal picturePath As String, _
ByVal targetRange As Range, _
ByVal shapeName As String)
Dim shp As Shape
Dim scaleW As Double
Dim scaleH As Double
Dim scaleFactor As Double
Set shp = ws.Shapes.AddPicture( _
Filename:=picturePath, _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=targetRange.Left, _
Top:=targetRange.Top, _
Width:=-1, _
Height:=-1)
shp.LockAspectRatio = msoTrue
scaleW = targetRange.Width / shp.Width
scaleH = targetRange.Height / shp.Height
If scaleW < scaleH Then
scaleFactor = scaleW
Else
scaleFactor = scaleH
End If
shp.Width = shp.Width * scaleFactor
shp.Height = shp.Height * scaleFactor
shp.Left = targetRange.Left + (targetRange.Width - shp.Width) / 2
shp.Top = targetRange.Top + (targetRange.Height - shp.Height) / 2
shp.Placement = xlMoveAndSize
shp.Name = shapeName
End Sub
Private Sub DeletePhotoShapes(ByVal ws As Worksheet, ByVal prefix As String)
Dim i As Long
For i = ws.Shapes.Count To 1 Step -1
If Left$(ws.Shapes(i).Name, Len(prefix)) = prefix Then
ws.Shapes(i).Delete
End If
Next i
End Sub
コードの使い方
このコードは、写真台帳 というシートへ写真を貼り付けます。
まだ 写真台帳 シートがない場合は、自動で作成します。ただし、実際の提出用テンプレートに合わせる場合は、あらかじめ写真枠やコメント欄を作ったシートを用意し、シート名を 写真台帳 にしておく方が扱いやすいです。
使い方の流れは次のとおりです。
- テスト用のExcelブックを用意する
写真台帳シートを作る- 写真枠にしたいセル範囲を決める
- VBAエディターで標準モジュールを追加する
- コードを貼り付ける
photoRangesとfileNameCellsを必要に応じて変更する- マクロを実行する
- 写真フォルダを選択する
- 貼付結果を確認する
コード内では、次の部分が写真枠です。
photoRanges = Array("B4:H15", "J4:P15", _
"B19:H30", "J19:P30", _
"B34:H45", "J34:P45")
この範囲を、自分のテンプレートに合わせて変更します。
たとえば、1ページ3枚の写真台帳なら、3つの範囲だけを指定する形に変更できます。1ページ6枚なら、今回のように6つの範囲を指定します。
調整が必要なポイント
このコードは、一般的な写真台帳の考え方をもとにしたサンプルです。
実務で使う場合は、次の点を確認してください。
- 写真枠のセル範囲
- ファイル名を表示するセル
- 写真タイトルやコメントを入れるセル
- 1ページあたりの写真枚数
- ページごとの行数
- 印刷範囲
- 余白
- 行高と列幅
- 結合セルの有無
- PDF出力時の見え方
特に、写真枠が結合セルになっている場合、見た目と実際のセル範囲が一致していないことがあります。写真枠として指定する範囲は、印刷したときに写真を収めたい範囲と一致させてください。
また、コード内の PAGE_ROW_HEIGHT は、次ページへ進むときの行数です。テンプレートの1ページ分の高さに合わせて変更する必要があります。
VBAでも最終確認が必要な範囲
VBAで写真を貼り付けても、提出用成果品としてそのまま使えるかどうかは別問題です。
次のような確認は、人間が行う必要があります。
- 写真が正しい順番で貼られているか
- 写真とファイル名が対応しているか
- コメント欄と写真がずれていないか
- 写真が枠内に収まっているか
- 写真が歪んでいないか
- 印刷時に写真が切れていないか
- PDF出力後にレイアウトが崩れていないか
- 発注者様式や社内様式に合っているか
VBAは、単純な貼付作業を軽くするには便利です。しかし、写真の内容が正しいか、提出資料として妥当かまでは判断してくれません。
印刷とPDF出力は必ず確認する
Excel写真台帳では、画面上の見た目だけで判断しない方が安全です。
写真が枠内にきれいに収まっていても、印刷プレビューで見ると少しずれていたり、PDFにすると文字が切れていたりすることがあります。
特に、次の設定はレイアウトに影響します。
- 印刷範囲
- 拡大縮小率
- 余白
- 用紙サイズ
- 改ページ
- プリンタ設定
- 行高
- 列幅
- 結合セル
提出前には、Excel画面、印刷プレビュー、PDF出力後の3段階で確認するのが安全です。
免責と注意事項
この記事で紹介したVBAコードは、写真台帳作成を補助するためのサンプルです。
利用するExcelのバージョン、シート構成、結合セル、印刷範囲、画像サイズ、余白設定によって、調整が必要になる場合があります。
実務ファイルで実行する前に、必ずバックアップを取ってください。まずはテスト用ブックとテスト用写真で動作確認してください。マクロを使うには、Excel側でマクロを有効化する必要があります。
提出用成果品として使う場合は、写真とコメントの対応、印刷結果、PDF出力結果、発注者・社内様式との整合を必ず人間が確認してください。
コード利用による損害、データ破損、提出物不備等について、維持DXは責任を負いません。
まとめ
写真台帳をExcelで作る場合、写真を1枚ずつ貼り付ける作業はかなり手間です。
VBAを使えば、指定フォルダ内の写真を順番に取得し、写真枠へ貼り付け、ファイル名を記入するところまで自動化できます。
ただし、テンプレートのセル範囲、結合セル、印刷範囲、余白、PDF出力結果は環境によって変わります。コードを貼れば何でも完成するわけではありません。
維持DXでは、Excel帳票、写真台帳、成果品整理、VBA自動化など、現場実務の中で発生しやすい作業負担を軽くする考え方を整理しています。
写真台帳も、まずは写真枠とファイル名の対応を崩さないところから始めると、作業の見通しがかなり良くなります。
■ダウンロード
無料ダウンロード（Excel）
維持DXでは建設コンサルタント実務を軽くするツールを無料で公開しています。
以下のフォームにメールアドレスを入力すると、ダウンロードURLを自動返信メールでお送りします。
ご注意
ダウンロードURLは、入力いただいたメールアドレス宛に自動返信で送信されます。
ダウンロードしたExcelでマクロが実行できない場合は、
右クリック → プロパティ →「許可する」 をチェック後、再度開いてください。
Windowsのセキュリティ機能により、初回実行時にマクロがブロックされる場合があります。
