Nutzen Sie unser 
Per VBA lassen sich Bilder aus einem angegebenen Verzeichnis auslesen und importieren. Die vorgestellte Prozedur liest die Bilder aus dem eingestellten Verzeichnis "F:\Pic" aus. Die im Verzeichnis vorhandenen Bilder werden entsprechend der Spaltenbreite der Spalte A skaliert. Die Bilder werden vergrößert oder verkleinert, wobei die Seitenverhältnise unverändert bleiben. Damit befindet sich das Bild genau innerhalb einer Zelle.
Im vorstellten Beispiel beginnt der Import in Zeile 5 der Spalte A.
Erfassen Sie den VBA-Code in einem Code-Modulblatt.
Sub BilderImport()
'*********************************************************************************
'** Bilder werden in die Spalte A eingefügt. Die Bilder werden auf die
'** eingestellte Spaltebreite skaliert. Die Zeilenhöhe wird an die
'** skalierte Bildhöhe angepasst
'*********************************************************************************
'* * Dimensionierung der Variablen
Dim strVerzeichnis$, strDatei$
Dim pct As Picture
Dim lngZeile As Long'Zeile zum Eintragen der Bilder
Dim lngSpalte As Long'Spalte zum Eintragen der Bilder
Dim varBreite As Variant'Spaltenbreite
Dim varHoehe As Variant
'** Verzeichnis und Dateinamen definieren und auslesen
strVerzeichnis = "F:\Pic"
strDatei = Dir(strVerzeichnis & "\*.jpg")
'** Startzeile + Spalte festelegen
lngZeile = 5
lngSpalte = 1
'** Ermittlung der Spaltenbreite
varBreite = Columns("A:A").Width
Cells(lngZeile, lngSpalte).Select
Cells(lngZeile, lngSpalte + 1) = strDatei ' schreiben Dateinamen
Set pct = ActiveSheet.Pictures.Insert(strVerzeichnis & "\" & strDatei)
With ActiveSheet.Shapes("Picture 1")
'** Auslesen der Breite
ActiveSheet.Shapes("Picture 1").Select
Selection.ShapeRange.LockAspectRatio = msoTrue
'** Bild auf aktuelle Spaltenbreite skalieren
Selection.ShapeRange.Width = varBreite
'** Zeilenhöhe festlegen
varHoehe = ActiveSheet.Shapes("Picture 1").Height
Rows(lngZeile).RowHeight = varHoehe
End With
'** Zähler für Shape definieren
shp = 2
'** Zeilenzähler erhöhen
lngZeile = lngZeile + 1
'** Bild 2 bis n durchlaufen
Do While strDatei <> ""
strDatei = Dir()
If strDatei = "" Then Exit Do
Cells(lngZeile, lngSpalte).Select
Set pct = ActiveSheet.Pictures.Insert(strVerzeichnis & "\" & strDatei)
ActiveSheet.Shapes("Picture " & shp).Select
Cells(lngZeile, lngSpalte + 1) = strDatei ' schreiben Dateinamen
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Width = varBreite '* 5.355 'Bild auf Spaltenbreite skallieren
'** Zeilenhöhe festlegen
varHoehe = ActiveSheet.Shapes("Picture " & shp).Height
Rows(lngZeile).RowHeight = varHoehe
'** Zeilenzähler erhöhen
lngZeile = lngZeile + 1
'** Shape-Zahler erhöhen
shp = shp + 1
Loop
End Sub
