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").ClearContents
Dim i As Integer
For i = 4 To 1000
If Tabelle1.Cells(i, 2).Value <> "" Then
If Dir$(Tabelle1.Cells(i, 2).Value) = "" Then
Tabelle1.Cells(i, 1).Value = "X"
Else
With Tabelle1.Pictures.Insert(Tabelle1.Cells(i, 2).Value)
.Height = 60
.Top = Tabelle1.Cells(i, 1).Top + (Tabelle1.Cells(i, 1).Height - .Height) / 2
.Left = Tabelle1.Cells(i, 1).Left + (Tabelle1.Cells(i, 1).Width - .Width) / 2
.Placement = xlMoveAndSize
End With
End If
End If
Next i
End Sub