Folgethread "Bild per VBA einfügen"

Informationen und Beispiele zu den hier genannten Dialog-Elementen:
Bild

Betrifft: Folgethread "Bild per VBA einfügen"
von: Jürgen
Geschrieben am: 08.07.2015 14:15:42

Hallo Leute
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

  • Option Explicit
    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

    Bild

    Betrifft: paar Vorarbeiten gemacht, aber offen
    von: Michael
    Geschrieben am: 08.07.2015 16:37:33
    Hallo Jürgen,
    es wird Dein Problem nicht lösen, aber die Crux sollte hier liegen:
    In der Zeile Set Set objCopy = Me.Shapes(Me.Shapes.Count) von copyPic hat Shapes.Count den Wert 8, nachdem ich Dein Makro mit F8 bis zum Einfügen des ersten Bildes zeilenweise habe durchlaufen lassen.
    Positioniert wird allerdings komischerweise der Commandbutton2.
    Für mal oben in Deinen Code Folgendes ein:

    sub grafik()
    Dim i As Long
    For i = 1 To Shapes.Count
    MsgBox Shapes(i).Name
    Next
    End Sub
    Komischerweise wird die neu eingefügte Grafik32 als erstes ausgegeben, ist also Shapes(1), und der CommandButton2 bei 8.
    Debug.Print ergibt folgende Werte ...
    Debug.Print "v: " & vntret & " " & rng.Address & _
           " " & rng.Offset(0, -1).Left & " " & rng.Offset(0, -1).Top

    v: 34 $AH$6 1178,25 94,5
    v: 35 $AH$7 1178,25 114
    v: 52 $AH$9 1178,25 153
    v: 53 $AH$10 1178,25 172,5
    v: 54 $AH$11 1178,25 192
    v: 55 $AH$12 1178,25 211,5
    v: 56 $AH$13 1178,25 231
    v: 37 $AH$14 1178,25 250,5
    v: 38 $AH$15 1178,25 270
    v: 39 $AH$16 1178,25 289,5
    v: 40 $AH$17 1178,25 309
    v: 42 $AH$18 1178,25 328,5
    v: 43 $AH$19 1178,25 348
    ... die natürlich abhängig sind von diversen Einstellungen; sie sehen aber "gut" aus, insbesondere ist der "left" genau untereinander - keine Ahnung.
    Schöne Grüße,
    Michael

    Bild

    Betrifft: AW: paar Vorarbeiten gemacht, aber offen
    von: Armin
    Geschrieben am: 08.07.2015 16:47:29
    Hallo Jürgen,
    der Fehler lag in der Procedure

    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
          Target.PasteSpecial
          Set objCopy = Me.Shapes(Me.Shapes.Count)
          objCopy.Left = Target.Left
          objCopy.Top = Target.Top
          Exit Sub
        End If
      Next
    End With
    End Sub 
    Die Positionierung muss immer auf der Zelle die Du benutzen möchtest.
    in AI3 + AJ3 ist ein Fehler in der Formel den musst Du selbst suchen. Es ist einfach zu viel Aufwand sich da hinein zu denken.

    Bild

    Betrifft: AW: paar Vorarbeiten gemacht, aber offen
    von: Jürgen
    Geschrieben am: 08.07.2015 17:22:13
    Super vielen Dank
    Hab nun auch herausgefunden warum das ganze diagonal 2 mal und dann beim 3tenmal geklappt hat.
    Ich hatte in 2 Zellen Kommentare drinstehen als ich die gelöscht habe ging der Code wieder.
    Das war das was ich als aller letztes noch als Infos hinzugefügt habe. Schon komisch wie sowas kleines so eine grosse Wirkung haben kann :-)
    Aber mit

  • Target.PasteSpecial

  • klappt es nun auch mit den Kommentaren
    DANKE
    mfg
    Jürgen

     Bild

    Beiträge aus den Excel-Beispielen zum Thema "Topt 10 Liste mit Details nach wählbarem Datum"