Ich möchte aus einer eigenen Tabelle über einen Schlüssel pro Seite 4 Mitarbeiterfotos übernehmen; vor der Übernahme soll das Makro alte Fotos löschen. Die Übernahme funktioniert problemlos, nur beim Löschen bekomme ich bei den letzten beiden Bildern die Meldung "Der Index in der angegebenen Sammlung ist außerhalb des zulässigen Bereichs". Ich muß das Löschen exakt auf "pct.." abfragen, da bei einem generellen Löschen aller Grafiken auch Buttons und Pfeile gelöscht würden. Namen der Bilder beginnen garantiert mit "pct..." und die Variable anzShapes zeigt auch x-mal überprüft die korrekte Anzahl von Grafiken.
Sub Bildübernahme_Sheet1()
Dim name1, name2, name3, name4 As String
Dim oben1, oben2, oben3, oben4 As Integer
Dim links1, links2, links3, links4 As Integer
Dim anzShapes, cntShapes As Byte
Worksheets(1).Activate
name1 = "pct" & ActiveSheet.Range("A19")
oben1 = ActiveSheet.Range("A21")
links1 = ActiveSheet.Range("A22")
name2 = "pct" & ActiveSheet.Range("A26")
oben2 = ActiveSheet.Range("A28")
links2 = ActiveSheet.Range("A29")
name3 = "pct" & ActiveSheet.Range("A33")
oben3 = ActiveSheet.Range("A35")
links3 = ActiveSheet.Range("A36")
name4 = "pct" & ActiveSheet.Range("A39")
oben4 = ActiveSheet.Range("A41")
links4 = ActiveSheet.Range("A42")
anzShapes = ActiveSheet.Shapes.Count
For cntShapes = 1 To anzShapes
* In der folgenden Zeile liegt das Problem ....
If Left(ActiveSheet.Shapes(cntShapes).Name, 3) = "pct" Then
ActiveSheet.Shapes(cntShapes).Delete
End If
Next cntShapes
Sheets("Fotos").Shapes(name1).Copy
ActiveSheet.Paste
ActiveSheet.Shapes(name1).Top = oben1
ActiveSheet.Shapes(name1).Left = links1
Range("a2").Select
Sheets("Fotos").Shapes(name2).Copy
ActiveSheet.Paste
ActiveSheet.Shapes(name2).Top = oben2
ActiveSheet.Shapes(name2).Left = links2
Range("a2").Select
Sheets("Fotos").Shapes(name3).Copy
ActiveSheet.Paste
ActiveSheet.Shapes(name3).Top = oben3
ActiveSheet.Shapes(name3).Left = links3
Range("a2").Select
Sheets("Fotos").Shapes(name4).Copy
ActiveSheet.Paste
ActiveSheet.Shapes(name4).Top = oben4
ActiveSheet.Shapes(name4).Left = links4
Range("a2").Select
Calculate
End Sub
Ich hoffe ihr habt einen Tipp für mich, denn ich bin mit meinem Latein am Ende ...
Vielen Dank - Helmut