Sub BilderEinfuegen()
Dim i As Long
Dim PicBild As Picture
Dim PfadDatei$, PfadBilder$
Dim Objekt As Object
Dim arrBereiche As Variant
arrBereiche = Array("A6,L24", "N6,Y24", "A28,L46", "N28,Y46", "A51,L69", "N51,Y69", "A73,L91", "N73,Y91", _
"A96,L114", "N96,Y114", "A118,L136", "N118,Y136", "A141,L159", "N141,Y159", "A163,L181", "N163,Y181", _
"A186,L204", "N186,Y204", "A208,L226", "N208,Y226")
PfadDatei = ThisWorkbook.Path
PfadBilder = PfadDatei & "\Bilder\"
Application.ScreenUpdating = False
For Each Objekt In ActiveSheet.Shapes
If Objekt.AlternativeText <> "Bilder einfügen" Then
Objekt.Delete
End If
Next
For i = 0 To UBound(arrBereiche) Step 1
If Range(arrBereiche(i)).Value > "00" Then
Set PicBild = _
ActiveSheet.Pictures.Insert(PfadBilder & Range(arrBereiche(i)).Value & ".jpg")
With ActiveSheet.Pictures(ActiveSheet.Pictures.Select)
PicBild.Top = Range(arrBereiche(i)).Top
PicBild.Left = Range(arrBereiche(i)).Left
If ActiveSheet.Pictures(ActiveSheet.Pictures.Count).Width > _
ActiveSheet.Pictures(ActiveSheet.Pictures.Count).Height Then
PicBild.Width = Range(arrBereiche(i)).Width
PicBild.Top = Range(arrBereiche(i)).Top + _
(Range(arrBereiche(i)).Height - ActiveSheet.Pictures(ActiveSheet.Pictures.Count).Height) / 2
Else
PicBild.Height = Range(arrBereiche(i)).Height
PicBild.Left = Range(arrBereiche(i)).Left + _
(Range(arrBereiche(i)).Width - ActiveSheet.Pictures(ActiveSheet.Pictures.Count).Width) / 2
End If
End With
Else
End If
Next i
Application.ScreenUpdating = True
Set PicBild = Nothing
End Sub