Sub Alle_Bilder_Einfügen()
Dim sDatei As String, sPfad As String
Dim oZelle As Range, oRette As Range
Dim ScaleA As Double
On Error Resume Next
Set oRette = ActiveCell
Set oZelle = Application.InputBox(Prompt:="Bitte Zielzelle wählen!", _
Default:=Cells(Rows.Count, "C").End(xlUp).Offset(1, -1).Address, Type:=8)
If oZelle Is Nothing Then Exit Sub
sPfad = "D:\Pictures\Fotos\IGF\"
sDatei = Dir(sPfad & "*.*")
Do While sDatei <> ""
Select Case LCase$(Right(sDatei, 4))
Case ".bmp", ".jpg", ".tif", ".gif", ".png", "jpeg"
With ActiveSheet.Pictures.Insert(sPfad & sDatei)
With .ShapeRange
.Top = oZelle.Top
.Left = oZelle.Left
ScaleA = WorksheetFunction.Min(oZelle.Width / .Width, oZelle.Height / .Height)
.Height = .Height * ScaleA
End With
.Placement = xlMoveAndSize
.PrintObject = True
End With
Set oZelle = oZelle.Offset(1, 0)
End Select
sDatei = Dir
Loop
oRette.Select
End Sub