Office: (Office 2016) Bild mit Text aus Zelle verknüpfen

Hi Ralf,

ich habe deine Mappe jetzt getestet und folgendes festgestellt: beim 2. Bild in Spalte C steht
3000 C-300365-2 - Twilight at Woodgreen Pond (CASTORLAND). Dort fehlt zwischen 3000 und C der - , stattdessen gibt es dort ein Leerzeichen, sodass das Tabellenblatt "3000 Cer" gesucht aber logischerweise nicht gefunden wird und deshalb ein Laufzeitfehler auslöst wird. Der Code ist nämlich so aufgebaut, dass er genau nach diesem ersten "-" sucht und die Zeichen links davon mit dem Zusatz "er" (also 3000er) als Ziel-Tabellennamen nimmt. Wenn man in der Zelle die Leerstelle durch - ersetzt werden alle Bilder übertragen.

Frage: gibt es bei dir keinen Laufzeitfehler? Mir ist nämlich aufgefallen, dass es in der Ja/Nein-Liste noch weitere Bildnamen gibt, bei denen anstelle des "-" ein Leerzeichen steht.

---

 

Guten Tag Karin
Ich kann es kaum Fassen. Dieser kleine blöde Strich hat den ganzen Wirbel verursacht!!! Einen Laufzeitfehler hat der Code am Ende auch bei mir angezeigt.
Jetzt bin ich aber doch sehr Froh, dass ich auch dieses Bild mit in die Mini Datei aufgenommen habe. Hättest Du sonst auch nicht gefunden oder????? Ich jedenfalls habe das nicht gesehen, das der Strich fehlte.
Alle anderen Texte haben nämlich diesen Strich hinter den Ziffern. Nur dieses eine Bild eben nicht.
Hier ist es eben so, dass ich den Code und seinen Ablauf nicht Verstehe. Sonst hätte ich das eventuell auch gefunden.
Was ich an Deinem Code rausgefunden hatte ist, dass Du für die Hochkantbilder eine Zeilenanzahl von 19 angegeben hast. Da hatte ich gesehen das eine Zeile unter dem Bild fehlte. Das konnte ich mit ändern auf 20 beheben. Aber auf diesen Schreibfehler meinerseits wäre ich nicht gekommen.
Was mir aber auch nicht einleuchtet ist, warum dann Bilder die vor diesem Fehler stehen auch nicht übergeben wurden und Bilder die dahinter stehen wiederum doch.
Kannst Du mir bitte schreiben in welcher Reihenfolge der Code abläuft?
Fazit ist: Alle Texte und Bilder werden an die richtigen Blätter übergeben und läuft damit EINWANDFREI.
Du hast mich sehr Glücklich gemacht. Deine Arbeit hilft mir sehr. Ich habe damit weniger Aufwand und spare sehr viel Zeit.

Ich bedanke mich recht herzlich für Deine Unterstützung und Fühle Dich bitte lieb gedrückt und geküst. Spitzenmäßig gelöst.
Danke, Danke
Angenehme Woche und für den Fall das wir Uns vor dem Weihnachtsfest und Jahreswechsel nicht mehr schreiben (müssen) wünsche ich Dir ein Frohes Fest und einen guten Rutsch ins neue Jahr in dem Du hoffentlich vielen anderen Ratsuchenden helfen kannst.

Schönen Dank nochmal
Ralf B. aus B. an der E.

 

Hi Ralf,

als generelle Vorgehensweise: wenn ein Code nicht das macht was er soll und man nicht weiss weshalb, aber besonders dann wenn ein Fehler auftritt, sollte man sich angewöhnenen, als erstes den Inhalt der verwendeten Variablen zu prüfen - und da ist mir eben aufgefallen, dass strTab bei einem Bild "3000 C" enthielt. Und richtig: hättest du dieses Bild nicht mit aufgenommen, hätte ich den Fehler nicht (zumindest nicht so schnell) finden können, weil kein Laufzeitfehler aufgetreten wäre.

Dass bei dir einige Bilder vor diesem problematischen nicht übertragen wurden und dafür andere danach, liegt m.E. darin begründet, dass du sie wahrscheinlich nicht in der Reihenfolge in die Tabelle eingefügt hast, in der sie bei dir vorliegen. Beim Einfügen von Objekten vergibt Excel automatisch eine interne ID und bei einer Schleife über diese Objekte folgt Excel dann der fortlaufenden ID und nicht der Reihenfolge im Tabellenblatt.

Ich hatte zuerst einfach nur ein Bild gedreht, um eins im Hochformat zu haben, aber da hat Excel mir einen Strich durch die Rechnung gemacht: Breite und Höhe werden dadurch nicht getauscht und alle Bilder entsprachen trotzdem der Bedingung Breite > Höhe, sodass ich die andere Bedingung nicht testen konnte. Also habe ich einfach eins genommen und von Hand annähernd höher gezogen und in der Breite verkleinert - diese Maße entsprachen dann offensichtlich nicht den tatsächlichen eines hochformatigen Bildes. Prima, dass du selbst herausgefunden hast, dass es + 20 und nicht + 19 heißen muss.

Hier nochmal den Code mit Kommentaren, damit du besser verstehen kannst was wie abläuft:

Code:

Sub BilderEinfuegen()
    Dim lngLetzte As Long
    Dim shaShape As Shape
    Dim strTab As String
    Dim strName As String
    Dim rngSuche As Range
    Application.ScreenUpdating = False
    ' Schleife über alle Shapes
    For Each shaShape In Worksheets("ALLE PUZZLES").Shapes
        ' Name des Shapes <> Namen des Shapes das den Code gestartet hat (Schaltfläche)
        If shaShape.Name <> ActiveSheet.Shapes(Application.Caller).Name Then
            ' Zelle oberhalb des Shapes ist nicht leer, Bild liegt korrekt unterhalb
            If shaShape.TopLeftCell.Offset(-1, 0) <> "" Then
                ' alle Zeichen von Links bis zum ersten "-" vom Zellinhalt oberhalb abtrennen
                strTab = Left(shaShape.TopLeftCell.Offset(-1, 0), InStr(shaShape.TopLeftCell.Offset(-1, 0), "-") - 1)
                ' Bildtext aus Zelle oberhalb des Shapes
                strName = shaShape.TopLeftCell.Offset(-1, 0)
            ' Zelle oberhalb des Shapes ist leer, Bild liegt AUF der Zelle mit dem Namen
            Else
                ' alle Zeichen von Links bis zum ersten "-" vom Inhalt der Zelle abtrennen, auf dem das Shape liegt
                strTab = Left(shaShape.TopLeftCell, InStr(shaShape.TopLeftCell, "-") - 1)
                ' Bildtext aus Zelle auf dem das Shape liegt
                strName = shaShape.TopLeftCell
            End If
            ' Shape kopieren
            shaShape.Copy
            ' bezieht sich auf Tabelle mit dem Variableninhalt + "er"
            With Worksheets(strTab & "er")
                ' suche den Variableninhalt (Bildtext)
                Set rngSuche = .Columns(1).Find(strName, lookat:=xlWhole)
                ' Variableninhalt nicht gefunden, deshalb Shape noch nicht kopiert
                If rngSuche Is Nothing Then
                    ' letzte belegte Zeile in Spalte A
                    lngLetzte = .Cells(Rows.Count, 1).End(xlUp).Row
                    ' letzte belegte Zeile in Spalte A ist nicht leer, deshalb muss der Abstand vom letzten
                    ' Bildtext festgelegt werden um das kopierte Shape und Bildtext richtig einfügen zu können
                    ' falls letzte belegte Zelle leer ist handelt es sich um Zeile 1, dann kein Abstand nötig
                    If .Cells(lngLetzte, 1) <> "" Then
                        ' Höhe des Shape < Breite (entspricht Querformat)
                        If .Shapes(.Shapes.Count).Height < .Shapes(.Shapes.Count).Width Then
                            ' neue Zeile für Bildtext muss letzte Zeile + 13 sein
                            lngLetzte = lngLetzte + 13
                        ' Höhe des Shape > Breite (Hochformat)
                        Else
                            ' neue Zeile für Bildtext muss letzte Zeile + 20 sein
                            lngLetzte = lngLetzte + 20
                        End If
                    End If
                    ' kopiertes Shape in ermittelte Zeile + 1 (Zeile unterhalb des nächsten Bildtextes) einfügen
                    .Cells(lngLetzte + 1, 1).PasteSpecial Paste:=xlAll
                    ' Bildtext in ermittelte Zeile einfügen
                    .Cells(lngLetzte, 1) = strName
                End If
            End With
            ' Zelle oberhalb des Shapes ist nicht leer, Bild liegt korrekt unterhalb
            If shaShape.TopLeftCell.Offset(-1, 0) <> "" Then
                ' alle Zeichen ab "(" vom Zellinhalt oberhalb des Shape
                strTab = Mid(shaShape.TopLeftCell.Offset(-1, 0), InStr(shaShape.TopLeftCell.Offset(-1, 0), "(") + 1)
            ' Zelle oberhalb des Shapes ist leer, Bild liegt AUF der Zelle mit dem Namen
            Else
                ' alle Zeichen ab "(" vom Inhalt der Zelle abtrennen, auf der das Shape liegt
                strTab = Mid(shaShape.TopLeftCell, InStr(shaShape.TopLeftCell, "(") + 1)
            End If
            ' das Zeichen ")" am Ende des Bildtextes noch abtrennen
            strTab = Application.Substitute(strTab, ")", "")
            ' bezieht sich auf das Tabellenblatt mit dem Variableninhalt
            With Worksheets(strTab)
                ' suche den Variableninhalt (Bildtext)
                Set rngSuche = .Columns(1).Find(strName, lookat:=xlWhole)
                ' Variableninhalt nicht gefunden, deshalb Shape noch nicht kopiert
                If rngSuche Is Nothing Then
                    ' letzte belegte Zeile in Spalte A
                    lngLetzte = .Cells(Rows.Count, 1).End(xlUp).Row
                    ' letzte belegte Zeile in Spalte A ist nicht leer, deshalb muss der Abstand vom letzten
                    ' Bildtext festgelegt werden um das kopierte Shape und Bildtext richtig einfügen zu können
                    ' falls letzte belegte Zelle leer ist handelt es sich um Zeile 1, dann kein Abstand nötig
                    If .Cells(lngLetzte, 1) <> "" Then
                        ' Höhe des Shape < Breite (entspricht Querformat)
                        If .Shapes(.Shapes.Count).Height < .Shapes(.Shapes.Count).Width Then
                            ' neue Zeile für Bildtext muss letzte Zeile + 13 sein
                            lngLetzte = lngLetzte + 13
                        Else
                            ' neue Zeile für Bildtext muss letzte Zeile + 20 sein
                            lngLetzte = lngLetzte + 20
                        End If
                    End If
                    ' kopiertes Shape in ermittelte Zeile + 1 (Zeile unterhalb des nächsten Bildtextes) einfügen
                    .Cells(lngLetzte + 1, 1).PasteSpecial Paste:=xlAll
                    ' Bildtext in ermittelte Zeile einfügen
                    .Cells(lngLetzte, 1) = strName
                End If
            End With
        End If
    Next shaShape
    Application.ScreenUpdating = True
End Sub

---

 

Guten Tag Karin
Vielen Dank für diese Erklärung im Code.
Das hilft mir diesen Code zu Verstehen. Macht mich aber leider nicht zu einem VBA Liebhaber. Der nächste Code wird für mich wieder ein Rätsel sein.
Für dieses Thema bin ich aber voll und ganz zufrieden.
Vielen Dank für Deine freundliche und Kompetente Hilfe. Note: 1A*

Mit freundlichen Grüßen
Ralf B. aus B. an der E.