Hallo nochmal,

ich habe das oben beschriebene Problem gelöst und mein Script noch etwas verfeinert. Jedoch habe ich immer noch ein Problem. Die Bilder werden zwar in die richtigen Zellbereiche eingefügt, jedoch nicht wie gewollt ausgerichtiet und größenmäßig angepaßt. Sprich die Top, Left, Width und Height Zuweisungen sind irgendwie nicht richtig. Die Bilder werden nicht in den kompletten verbundenen Zellbereich eingepaßt sondern nur in der oberen linken Zelle. Vielleicht sieht ja einer, wo da der Fehler liegt. Ansonsten läuft das Script fehlerfrei.

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
   'Löschen bereits eingefügter Bilder
   For Each Objekt In ActiveSheet.Shapes
   If Objekt.AlternativeText <> "Bilder einfügen" Then
   Objekt.Delete
   End If
   Next
   'In die Zellbereiche werden Bilder mit dem dort stehenden Namen eingefügt
   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)
                'Ausrichten der Bilder
                PicBild.Top = Range(arrBereiche(i)).Top
                PicBild.Left = Range(arrBereiche(i)).Left
                'Bild quer
                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
                'Bild hochkant
                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
        'In Zellbereichen mit dem Wert 00 werden keine Bilder eingefügt
        End If
    Next i
    Application.ScreenUpdating = True
    Set PicBild = Nothing
End Sub