フォルダ内のJPGファイルをフォルダごとのシートを作成し、
そのシート内に自動で貼り付けします。
Sub JpgPut()
' JpgPut
' JPGファイルを貼り付ける。
' エビデンスが存在する1階層上のフォルダを指定する。(末尾\)
' フォルダ内のJPGファイルは100枚まで。
' 例)
' C:\work\ebi\を指定した場合、
' C:\work\ebi\imgフォルダ内のJPGファイルを貼り付ける。
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.DisplayStatusBar = True
Application.StatusBar = "処理中・・・"
Dim count As Integer
count = 0
Dim folderPath As String ' 環境によって変更すること。
folderPath = Worksheets(1).Cells(2, 1).Value
Dim fileName As String
fileName = Dir(folderPath & "\", vbDirectory)
Dim n As Integer
n = 0
Dim fileNames(100) As String
Do While fileName <> ""
fileNames(n) = fileName
n = n + 1
fileName = Dir()
Loop
Dim i As Integer
Dim j As Integer
For j = 0 To n
fileName = fileNames(j)
If GetAttr(folderPath & "\" & fileName) And vbDirectory Then
If fileName <> "." And fileName <> ".." And fileName <> "" Then
i = 0
Dim newSheet As Worksheet
Set newSheet = Worksheets.Add()
newSheet.Move after:=Worksheets(Worksheets.count)
newSheet.Name = fileName
Dim jpgPath As String
jpgPath = Dir(folderPath & "\" & fileName & "\" & "*.JPG", vbNormal)
Do While jpgPath <> ""
' 画像の高さに合わせて「45」の数値を変更すること。
newSheet.Cells(i * 45 + 1, 1).Value = jpgPath
newSheet.Cells(i * 45 + 2, 2).Select
' Excel2010の場合はここから
' 画像を1*1ポイントで貼り付け
Set myShape = Worksheets(fileName).Shapes.AddPicture( _
fileName:=folderPath & "\" & fileName & "\" & jpgPath, _
linkToFile:=False, _
saveWithdocument:=True, _
Left:=Selection.Left, _
Top:=Selection.Top, _
Width:=msoTrue, _
Height:=msoTrue)
' 画像を元のサイズに変換(Heightの設定は不要かも)
' Withを利用しないとオブジェクトエラーになる。
With myShape
LockAspecRatio = msoTrue
Hieght = 560
End With
'myShape.LockAspecRatio = msoTrue
'myShape.Hieght = 560
' Excel2010の場合はここまで
' Excel2013の場合はここから
'Worksheets(fileName).Picutures.Insert fileName:=folderPath & "\" & fileName & "\" & jpgPath
' Excel2013の場合はここまで
i = i + 1
count = count + 1
jpgPath = Dir()
Loop
End If
End If
Next j
Application.StatusBar = count & "個貼り付け完了"
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub