Office: (Office 2016) Bild von Blatt kopieren und auf einem anderen einfügen

Hallo Zusammen

Ausgangslage:
Ich habe ein Tabellenblatt "Schuhbestand" mit 30 Bildern darin. Diese sind auf von links nach rechts aufgereiht und von Zellposition und Grösse abhängig eingestellt. Jedes Bild ist 3 Spalten breit und 4 Zeilen hoch. Das erste Bild ist im Bereich C1:E4, das zweite in G1:I4 und so weiter. Zwischen den Bildbereichen ist jeweils eine leere Spalte.

Ziel:
Ich möchte nun die Bilder vom Tabellenblatt "Schuhbestand" in das Tabellenblatt "Übersicht" kopieren, ohne die Bezeichnung der Bilder zu benutzen. Jedes einzelne Bild muss ich im Tablellenblatt "Übersicht" beliebig platzieren können. Z.B. erstes Bild in A1:C4, zweites Bild in E1:G4 und so weiter.

Ich bin kein VBA Profi, daher bin ich um jede Hilfe froh. Am besten die Codefragmente direkt mit Kommentar versehen, dann verstehe ich diese auch. Danke! :)

lg Gabriel

 

Hola,

zur Info ;)

2.3: Crossposting - ist grundsätzlich erlaubt, aber nur wenn in dem Beitrag ein eindeutiger Verweis zu dem Thema im anderen Forum vorhanden ist.

Gruß,
steve1d

 

Man, war das so einfach festzustellen xD

Der Regelkonformität halber, hier der Verweis :) http://bit.ly/1PFohRY

 

Hi Gabriel,

versuche es mal auf diesem Weg

Code:

Sub BilderKopieren()
    Dim arrZellen()
    Dim shaBild As Shape
    Dim varVorhanden
    Dim dblLinks As Double
    Dim dblOben As Double
    ' Array mit allen Start- und Zieladressen für die Bilder - entsprechend ergänzen!
    arrZellen = Array(Array("C1", "G1", "K1"), Array("A1", "E1", "I1"))
    With Worksheets("Übersicht")
        ' Schleife über alle Shapes in "Schubestand"
        For Each shaBild In Worksheets("Schuhbestand").Shapes
            ' prüfen ob Adresse der linken oberen Zelle laufendes Shape im Array enthalten ist
            varVorhanden = Application.Match(shaBild.TopLeftCell.Address(0, 0), arrZellen(0), 0)
            ' wenn vorhanden dann ergibt Match einen numerischen WErt
            If IsNumeric(varVorhanden) Then
                ' laufendes bild kopieren
                shaBild.Copy
                ' Kopie einfügen
                .Paste
                ' feststellen Position der linken Kante der Zielzelle
                dblLinks = .Range(arrZellen(1)(varVorhanden - 1)).Left
                ' feststellen Position der oberen Kante der Zielzelle
                dblOben = .Range(arrZellen(1)(varVorhanden - 1)).Top
                ' Bezug auf das zuletzt eingefügte Shape
                With .Shapes(.Shapes.Count)
                    ' Positionen zuweisen
                    .Left = dblLinks
                    .Top = dblOben
                End With
            End If
        Next shaBild
    End With
End Sub

Bis später,
Karin

 

Hallo Karin

Auf den ersten Blick sieht das genau nach dem aus, was ich brauche. Ich versuche mich mal an deinem Ansatz, deine Kommentare sind aber ziemlich eindeutig formuliert. Danke! :D

lg Gabriel

 

Hoi Karin

Ich habe das so versucht wie du mir das vorgeschlagen hast und das hat auch auf Anhieb geklappt. Sobald ich aber mehr als 4 Bilder in die Arrays eingebe, kommt eine Fehlermeldung, der Abschnitt ".Paste" wird gelb markiert. Dieser Fehler scheint (zumindest in meiner Wahrnehmung) willkürlich aufzutreten. Manchmal werden X Bilder eingefügt, manchmal Y, manchmal erscheint die Fehlermeldung garnicht und es funktioniert alles einwandfrei. Ich habe selbst versucht, den Code anzupassen, bis jetzt konnte ich den Fehler noch nicht beheben.

Das ist mein aktueller Code:

Dim shaBild As Shape
Dim varVorhanden
Dim dblLinks As Double
Dim dblOben As Double
ersteZeile = Array(Array("C1", "G1", "K1", "O1", "S1", "W1", "AA1", "AE1"), Array("C14", "G14", "K14", "O14", "C35", "G35", "K35", "O35"))
With Worksheets("Übersicht")
For Each shaBild In Worksheets("Schuhbestand").Shapes
varVorhanden = Application.Match(shaBild.TopLeftCell.Address(0, 0), ersteZeile(0), 0)
If IsNumeric(varVorhanden) Then
shaBild.Copy
.Paste
dblLinks = .Range(ersteZeile(1)(varVorhanden - 1)).Left
dblOben = .Range(ersteZeile(1)(varVorhanden - 1)).Top
With .Shapes(.Shapes.Count)
.Left = dblLinks
.Top = dblOben
End With
End If
Next shaBild
End With

 

Hi,

das könnte daran liegen, dass Excel nicht genügend Zeit hat, das Bild einzufügen - ergänze mal die beiden Zeilen, vielleicht hilft das:

Code:

                shaBild.Copy
                [COLOR=#0000ff]DoEvents[/COLOR]
                ' Kopie einfügen
                .Paste
                [COLOR=#0000ff]DoEvents[/COLOR]

Bis später,
Karin

 

Danke für deine Hilfsbereitschaft, Karin. Ich habe es nun geschafft, dass alles funktioniert wie ich das möchte :)
Das DoEvents hat auf Jedenfall geholfen.

lg Gabriel