Folgethread "Bild per VBA einfügen"

Private Sub CommandButton2_Click() ' Kantenbild einfügen
Application.ScreenUpdating = False
On Error Resume Next
Range("AH3:AH3").Select   'Kantenregler aktualisieren Spalte AI
Selection.Copy
Range("AH6:AH600").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("AG6").Select
Const cSpalte = 33     ' Spalte AG Bilder löschen ersetzt erasePic(Target As Range
Dim sh As Shape
For Each sh In ActiveSheet.Shapes
If sh.TopLeftCell.Column = cSpalte Then sh.Delete
Next sh
Dim rng As Range, rngA As Range
Dim vntret As Variant
Set rngA = ActiveCell
For Each rng In Range("AH6:AH600")
vntret = Application.Match(rng, Sheets("Kantenbild").Range("c2:C90"), 0)
'If IsNumeric(vntret) And rng  "" Then
' erasePic rng
copyPic rng.Offset(0, -1), CLng(vntret)
'Else
' erasePic rng
'End If
Next
rngA.Select
Application.ScreenUpdating = True
End Sub

Private Sub erasePic(Target As Range) 'Bilder löschen
'On Error Resume Next
'Dim objPic As Shape
'For Each objPic In Me.Shapes
'  If objPic.TopLeftCell.Row = Target.Row Then
'    objPic.Delete
'    Exit Sub
'  End If
'Next
'End Sub

Private Sub copyPic(Target As Range, Index As Long)  ' Kantenbild einfügen
On Error Resume Next
Dim objPic As Shape, objCopy As Shape
With Sheets("Kantenbild")
For Each objPic In .Shapes
If objPic.TopLeftCell.Row = Index Then
objPic.Copy
Me.Paste
Set objCopy = Me.Shapes(Me.Shapes.Count)
objCopy.Left = Target.Left
objCopy.Top = Target.Top
Exit Sub
End If
Next
End With
End Sub