Folgethread "Bild per VBA einfügen"
08.07.2015 14:15:42
Jürgen
Hallo Sepp
Ich hab ein kleines Problem mit einem VBA Code.
Das hier wäre der Beitrag wo mir Sepp geholfen hat.
https://www.herber.de/forum/archiv/1432to1436/t1433637.htm#1433662
Ich hab den Code geringfügig abgeändert hat auch immer geklappt. (auch im Originalzustand geht es nicht mehr.)
Nun wollte ich die Liste das erste mal mit richtigen Daten füttern und nun klappt es nicht mehr.
Das Phänomen ist das beim ersten Klick, fügt es die Bilder Diagonal ein beim 2 klick auch Diagonal und beim 3ten klick gehen sie senkrecht hinunter was auch gewünscht ist.
Aber an was liegt das? Hier mal den Code
Die Datei falls das weiterhilft, ich bin Ratlos.
https://www.herber.de/bbs/user/98708.xlt
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
Ich hoffe einer hat ne Idee
Danke
mfg
Jürgen