Option Explicit
Sub BesserBilder_Einfuegen()
Dim Path As String
Dim Func As String
Dim Form As String
Dim i As Integer
Dim j As Integer
Dim oShp As Shape
Rem Path = "XXX\"
Rem Func = ActiveSheet.Name
Rem Form = ".png"
Form = ".jpg"
i = 2
j = 3
While (i < 180)
While (j < 6)
On Error Resume Next
Set oShp = ActiveSheet.Shapes.AddPicture( _
Filename:=Path & Cells(i, j).Value & Func & Form, _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=Cells(i, j + 3).Left, _
Top:=Cells(i, j).Top, _
Width:=Cells(i + 10, j).Top - Cells(i, j).Top, _
Height:=Cells(i + 10, j).Top - Cells(i, j).Top)
If Err.Number = 0 Then
With oShp
.Name = "Pict " & Cells(i, j).Address(0, 0)
End With
Call MsgBox("Bild " & oShp.Name & vbNewLine & _
"an Position " & oShp.TopLeftCell.Address, _
vbInformation, _
"Gewonnen!")
End If
On Error GoTo 0
j = j + 1
Wend
i = i + 10
j = 3
Wend
End Sub
Sub Bonus()
Dim oShp As Shape
Dim arrN() As String
For Each oShp In ActiveSheet.Shapes
arrN = Split(oShp.Name, " ")
If Range(arrN(1)).Value = "" Then
If MsgBox("Bild " & oShp.Name & vbNewLine & _
"an Position " & oShp.TopLeftCell.Address, _
vbQuestion + vbYesNo, _
"Sicherheitsabfrage!") = vbYes Then oShp.Delete
End If
Next oShp
End Sub