Bilder automatisch zentrieren

Option Explicit
Public Function InternerName(ByVal Zelle As Range) As String
Application.Volatile
Dim Sh As Shape
For Each Sh In Zelle.Parent.Shapes
If Sh.TopLeftCell.Address = Zelle.Address Then
InternerName = Sh.Name
Exit Function
End If
Next Sh
InternerName = "Kein Bild gefunden"
End Function
Public Sub BilderAktualisieren(ByVal Tabelle As Worksheet)
Dim Zelle As Range, Sh As Shape
Dim i As Long, Dic As Object
Dim Merker As Range
Dim Bezeichnung As String
On Error GoTo Fehler
Application.ScreenUpdating = False
Set Merker = ActiveCell
Set Dic = CreateObject("Scripting.Dictionary")
'Alte Bilder löschen
For i = Tabelle.Shapes.Count To 1 Step -1
If Left(Tabelle.Shapes(i).Name, 7) = "intern_" Then
Tabelle.Shapes(i).Delete
End If
Next i
'vorhandene Bilder in Tabelle2 suchen
For Each Sh In Sheets("Tabelle2").Shapes
Set Dic(Sh.Name) = Sh
Next Sh
'Bezeichnung der Bilder in Tabelle suchen
'und Bild kopieren
For Each Zelle In Tabelle.UsedRange
Bezeichnung = Zelle.Text
If Dic.Exists(Bezeichnung) Then
Dic(Bezeichnung).Copy
Tabelle.Paste
Set Sh = Tabelle.Shapes(Tabelle.Shapes.Count)
Sh.Top = Zelle.Top
Sh.Left = Zelle.Left
Sh.Name = "intern_" & Zelle.Address
End If
Next Zelle
Merker.Activate
Fehler:
Application.ScreenUpdating = True
Dic.RemoveAll
Set Zelle = Nothing: Set Sh = Nothing
Set Dic = Nothing: Set Merker = Nothing
End Sub