複数の画像ファイルを挿入したい

質問

工事の仕事をしています。
報告書をエクセルで書いて出すのですが、
現場の写真を大量に撮影して貼り付けなければなりません。

「挿入」→「ファイルから」で一枚一枚貼り付けているのですが手間でなりません。

デジカメで撮影した写真なのでファイル名は連番です。
一括でワークシートにズラッと並べて挿入することはできないのでしょうか?

週末1-200枚の写真を貼る為に残業するのは堪えます。
良い知恵をお貸し下さい。

回答No.5

KenKen_SP · ベストアンサー

工事写真票の作成ですか？報告書の提出時期ですものね。(^^;)

工事写真ということで、次の点が重要になるかと思います。

1.　貼付けられる順番
　　工事の様子を時間を追って撮影している場合、順番が重要です。
2.　リサイズの問題
　　工事写真は正確性が求められます。リサイズする場合、縦横比を固定すべきです。

1と2をクリアしつつ、貼付けを楽にするには、EXCELではマクロしか解決方法がありません。個人的にはVIXをお勧めしますが、一応EXCELでのマクロをアップします。貼付け後のサイズはセルの高さにあわせています。必要があれば、コードをカスタマイズして下さい。

ただ、他の方からもご指摘があるとおり、EXCELに200枚の画像は無茶ですね。複数のブックに切り分けましょう。

なお、マクロ[InsertPictures]は#2.papayukaさんのコードをかなり拝借しておりますし、配列のソートプログラムも以前どこかで教えて頂いたものです。クイックソートの方が早いのですが、長くなるので、バブルソートで済ませています。

以下コード。

Option Explicit
Sub InsertPictures()

　　Dim fName As Variant
　　Dim i As Long
　　Dim Pict As Picture

　　fName = Application.GetOpenFilename("JPGファイル, *.jpg", MultiSelect:=True)
　　If IsArray(fName) Then
　　　　Application.ScreenUpdating = False
　　　　'配列に格納されたファイル名をソート
　　　　BubbleSort fName, True
　　　　For i = 1 To UBound(fName)
　　　　　　Set Pict = ActiveSheet.Pictures.Insert(fName(i))
　　　　　　With Pict
　　　　　　　　.TopLeftCell = ActiveCell
　　　　　　　　.ShapeRange.LockAspectRatio = msoTrue
　　　　　　　　'どちらかをコメントアウト
　　　　　　　　.ShapeRange.Height = ActiveCell.Height 'セルの高さリサイズ
　　　　　　　　'.ShapeRange.Width = ActiveCell.Width 'セルの幅にリサイズ
　　　　　　　　ActiveCell.Offset(0, 1) = fName(i) 'ファイル名書込み
　　　　　　End With
　　　　　　ActiveCell.Offset(2, 0).Activate
　　　　　　Application.StatusBar = "処理中：" & i & "/" & UBound(fName) & "枚目"
　　　　Next i
　　End If
　　With Application
　　　　.StatusBar = False
　　　　.ScreenUpdating = True
　　End With
　　Set Pict = Nothing
　　MsgBox i & "枚の画像を挿入しました", vbInformation

End Sub

'値の入替え
Public Sub Swap(ByRef Dat1 As Variant, ByRef Dat2 As Variant)

　　Dim varBuf As Variant
　　varBuf = Dat1
　　Dat1 = Dat2
　　Dat2 = varBuf

End Sub

'配列のバブルソート
Public Sub BubbleSort(ByRef aryDat As Variant, _
　　Optional ByVal SortAsc As Boolean = True)

　　Dim i As Long
　　Dim j As Long
　　For i = LBound(aryDat) To UBound(aryDat) - 1
　　　　For j = LBound(aryDat) To LBound(aryDat) + UBound(aryDat) - i - 1
　　　　　　If aryDat(IIf(SortAsc, j, j + 1)) > aryDat(IIf(SortAsc, j + 1, j)) Then
　　　　　　　　Call Swap(aryDat(j), aryDat(j + 1))
　　　　　　End If
　　　　Next j
　　Next i

End Sub

お礼

ありがとうございます。
今朝、早速先週分の資料で試めさせていただきました。
定時後数時間、四苦八苦してこなしていた作業が30分ほどで完了しました。

画像貼りにへこたれていささか手抜きとなっていた所見等もこれからはじっくり書けそうです。

何より週末一人ぽつんと残業の憂き目を見なくてすみそうなのが嬉しいです。