Sub Bild_Einfügen()
Dim rngPic As Range
Dim pic As Picture
Set rngPic = Range("A4:A1000")
For Each pic In ActiveSheet.Pictures
Debug.Print pic.Name; vbTab; pic.TopLeftCell.Address
If Not Intersect(pic.TopLeftCell, rngPic) Is Nothing Then
pic.Delete
End If
Next pic
Tabelle1.Range("A4:A1000").Select
Selection.ClearContents
Dim i As Integer
For i = 4 To 1000
If Tabelle1.Cells(i, 2).Value <> "" Then
On Error Resume Next
With Tabelle1.Pictures.Insert(Tabelle1.Cells(i, 2).Value)
.Height = 65
.Top = Tabelle1.Cells(i, 1).Top
.Left = Tabelle1.Cells(i, 1).Left
.Placement = xlMoveAndSize
End With
On Error GoTo 0
End If
Next i
End Sub