SI業界にいる方だとエビデンスを取るのはWinshot使って作業中にパシャパシャとったけど、
Excelにぜんぶ貼り付けるのは苦行だったりします。
そもそもこの作業無意味じゃね？ってのは偉い人達にまかせて、
偉い人たちが欲しいってものを楽してつくりたい！
そんな方へ。
拾いものを改造したものなので作りは粗いです。
ご容赦を。
■できること
Excelファイルに指定フォルダ内の画像をすべて貼り付ける。
A1セルを起点に上から下に向かって貼り付ける。
画像と画像の間は3行程度空ける。
■ExcelVBA
' 指定したフォルダにある画像ファイルを読み込み、EXCELに貼り付ける。
'
Sub pasteDirAllImage()
' 変数定義
Dim fileName As String
Dim targetCol As Integer
Dim targetRow As Integer
Dim targetCell As Range
Dim shell, myPath
Dim pos As Integer
Dim extention As String
Dim isImage As Boolean
' 選択セルを取得
targetCol = ActiveCell.Column
targetRow = ActiveCell.Row
' フォルダ選択画面を表示
Set shell = CreateObject("Shell.Application")
Set myPath = shell.BrowseForFolder(&O0, "フォルダを選んでください", &H1 + &H10, "C:\Users\USERNAME\")
Set shell = Nothing
' フォルダを選択したら...
If Not myPath Is Nothing Then
fileName = Dir(myPath.Items.Item.Path + "\")
Do While fileName <> ""
' ファイル拡張子の判別
isImage = True
pos = InStrRev(fileName, ".")
If pos > 0 Then
Select Case LCase(Mid(fileName, pos + 1))
Case "jpeg"
Case "jpg"
Case "gif"
Case Else
isImage = False
End Select
Else
isImage = False
End If
' 拡張子が画像であれば
If isImage = True Then
' 貼り付け先を選択
Cells(targetRow, targetCol).Select
Set targetCell = ActiveCell
' 画像読込み
ActiveSheet.Pictures.Insert(myPath.Items.Item.Path + "\" + fileName).Select
' 画像が大きい場合、画像サイズをセル幅に合わせる
'If Selection.Width > targetCell.Width Or Selection.Height > targetCell.Height Then
'If Selection.Width / targetCell.Width > Selection.Height / targetCell.Height Then
'Selection.Height = Selection.Height * (targetCell.Width / Selection.Width)
'Selection.Width = targetCell.Width
'Else
'Selection.Width = Selection.Width * (targetCell.Height / Selection.Height)
'Selection.Height = targetCell.Height
'End If
'End If
' 表示位置をセル中央に移動
Selection.Top = targetCell.Top + (targetCell.Height - Selection.Height) / 2
Selection.Left = targetCell.Left + (targetCell.Width - Selection.Width) / 2
' 貼り付け先行を+1
targetRow = targetRow + 30
End If
fileName = Dir()
Loop
MsgBox "画像の読込みが終了しました"
End If
End Sub