Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1684to1688
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Grafiken per VBA kopieren: .Top Eigenschaft

Grafiken per VBA kopieren: .Top Eigenschaft
14.04.2019 19:50:47
PinkPanther
Hallo zusammen,
ich bin neu hier im Forum angemeldet und ihr habt mir als stiller Beobachterin mit den bereits bestehenden Threads schon sehr oft weiter geholfen. Vielen Dank erstmal dafür!
Nun habe ich folgendes Problem, was ich bisher leider nicht gelöst bekomme, ich habe zwar den ein oder anderen Thread dazu gefunden, aber leider bisher immer ohne Lösung, die mir weitergeholfen hat:
Ich möchte per VBA den Inhalt einer Arbeitsmappe in die Blätter einer neuen Arbeitsmappe kopieren und das ganze inklusive aller Shape Objekte.
Um die Shapes (in diesem Fall einfach nur Bilder) im Zielsheet zu positionieren greife ich auf die .Top Eigenschaft zu. Leider ist es nun so, dass die Shapes nicht an den richtigen Positionen ankommen, sondern alle zwar in der korrekten Reihenfolge, aber ein bisschen zu weit oben und links. Je weiter die Grafik dabei vom Rand der Worksheets bzw. von Zelle A1 entfernt ist, desto größer ist die Differenz. Ich habe daher irgendwie das Gefühl, dass die Maßeinheiten zwischen Quelle und Ziel irgendwie skaliert sind... Wirklich gefunden habe ich aber nichts dazu.
Der betreffende Abschnitt ist der Abschnitt "Bilder kopieren". Ich muss dazu sagen, dass das Makro im Original noch weitere Abschnitte hat, da ich das Problem aber mit diesem Auszug nachstellen kann, sollte dieser Teil reichen, ansonsten wird es noch unübersichtlciher ;).
Folgende Zusatzinformationen habe ich noch:
1. Das Originalsheet wurde mit einem anderen Laptop, evtl. andere Excel Version erstellt (ich verwende 2016).
2. Einfach das Sheet in das andere Workbook zu kopieren geht leider nicht, da es sich um angebundene Datenquellen handelt, und alle "Nicht Excel Funktionen" bei dem Kopiervorgang sozusagen "verloren gehen sollen".
3. Es gibt ausgeblendete Zeilen in den Sheets, aber diese übernehme ich durch die Formatübernahme bevor ich die Grafiken einfüge (ebenso alle anderen Screeneinstellungen).
4. Wenn ich auf "Quellbild".Topleftcell.top zugreife habe ich leider den gleichen Effekt (manche Bilder in der Quelle beginnen genau in einer linken oberen Zellecke, womit ich dies überprüfen konnte).
5. Wenn ich hart auf die Ranges (auskommentierter Code) gehe scheint es zu funktionieren. Aufgrund der Aktivierung für die Zoomeinstellungen ist hier das Zielsheet aktiv --> die Ranges des Zielsheets werden verwendet. Da aber nicht alle Grafiken genau in einer Zellecke beginnen fände ich das unschön (auch wenn man es über Topleftcell.address dynamisieren würde).
6. Ich habe es auch ohne Screenupdating = False versucht ;)
Falls also jemand eine Idee hat, was es mit dieser "Skalierung" auf sich haben könnte wäre ich sehr dankbar. Ebenfalls, wenn jemand einen Alternativvorschlag hat.
Lg Sophie
Sub create_offline_WB()
Dim current_sheets_setting As Integer
Dim new_WB As Workbook
Dim copy_range As String
Dim source_WB As Workbook
Dim start_WS As Worksheet
Set start_WS = ThisWorkbook.ActiveSheet
Set source_WB = ThisWorkbook
'Screeneinstellungen
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Anzahl Sheets
Dim sheet As Variant
Dim sheets_count As Long
For Each sheet In source_WB.Sheets
sheets_count = sheets_count + 1
Next
'Create WB
Dim new_WBName As String
With Application
current_sheets_setting = .SheetsInNewWorkbook
.SheetsInNewWorkbook = sheets_count
Set new_WB = Workbooks.Add
new_WBName = new_WB.Name
.SheetsInNewWorkbook = current_sheets_setting
End With
'create mapping
Dim first_Visible As Worksheet
Dim WS_Count As Integer
Dim I As Integer 'Worksheet Identifier Quelle
Dim J As Integer 'Worksheet Identifier Ziel nicht notwendig, wenn ausgeblendete Sheets  _
_
_
ebenfalls kopiert werden, wird für Flexibilität beibehalten
J = 1
WS_Count = ActiveWorkbook.Worksheets.count
For I = 1 To WS_Count
If source_WB.Worksheets(I).visible = True And first_Visible Is Nothing Then
Set first_Visible = new_WB.Sheets(J)
End If
new_WB.Sheets(J).Name = source_WB.Worksheets(I).Name
J = J + 1
Next I
J = 1
WS_Count = ActiveWorkbook.Worksheets.count
For I = 1 To WS_Count
'Erstellen der Formate
source_WB.Worksheets(I).Cells.Copy
new_WB.Sheets(J).Activate
new_WB.Sheets(J).Cells.PasteSpecial xlPasteFormats
'Bereich bestimmen
copy_range = source_WB.Sheets(I).UsedRange.Address
Application.CutCopyMode = False
ActiveWindow.DisplayGridlines = False
'Zellfixierung un Zoomeinstellung
Dim split_row As Integer
Dim split_col As Integer
Dim split_cell_add As String
Dim sheet_Zoom As Integer
source_WB.Worksheets(I).Activate
If ActiveWindow.FreezePanes = True Then
split_row = ActiveWindow.SplitRow + 1
split_col = ActiveWindow.SplitColumn + 1
split_cell_add = Range(Cells(split_row, split_col), Cells(split_row, split_col)).Address
sheet_Zoom = ActiveWindow.Zoom
new_WB.Worksheets(I).Activate
new_WB.Worksheets(J).Range(split_cell_add).Select
ActiveWindow.FreezePanes = True
ActiveWindow.Zoom = sheet_Zoom
End If
'Bilder kopieren
Dim L As Integer     'Index Quelle
Dim M As Integer     'Index Ziel
Dim shape_top As Double
Dim shape_left As Double
Dim sourceShape As Variant
Dim targetShape As Variant
M = 1
If source_WB.Worksheets(I).Shapes.count > 0 Then
For L = 1 To source_WB.Worksheets(I).Shapes.count
Set sourceShape = source_WB.Worksheets(I).Shapes(L)
sourceShape.Copy
new_WB.Sheets(J).Paste
shape_top = sourceShape.Top
Debug.Print shape_top
shape_left = sourceShape.Left
Set targetShape = new_WB.Sheets(J).Shapes(M)
With targetShape
.Top = shape_top
.Left = shape_left
End With
'If M = 1 Then new_WB.Sheets(J).Shapes(M).Top = Range("C6").Top
'If M = 2 Then new_WB.Sheets(J).Shapes(M).Top = Range("C22").Top
'If M = 3 Then new_WB.Sheets(J).Shapes(M).Top = Range("C38").Top
'If M = 4 Then new_WB.Sheets(J).Shapes(M).Top = Range("C22").Top
'If M = 5 Then new_WB.Sheets(J).Shapes(M).Top = Range("C6").Top
'If M = 6 Then new_WB.Sheets(J).Shapes(M).Top = Range("C22").Top
'If M = 7 Then new_WB.Sheets(J).Shapes(M).Top = Range("C38").Top
'If M = 8 Then new_WB.Sheets(J).Shapes(M).Top = Range("C6").Top
'If M = 9 Then new_WB.Sheets(J).Shapes(M).Top = Range("C22").Top
M = M + 1
Next L
End If
'Auswahl Zelle
Range("A1").Select
J = J + 1                 'Nächstes ZielSheet
Next I           'Nächstes QuellSheet
Application.Wait Now + TimeValue("0:00:02")
'Screeneinstellungen
Application.ScreenUpdating = True
Application.CutCopyMode = False
Application.EnableEvents = True
Application.DisplayAlerts = True
start_WS.Activate
'Starten Speicherdialog
Dim Dialog As FileDialog
first_Visible.Activate
Set Dialog = Application.FileDialog(msoFileDialogSaveAs)
With Dialog
.InitialFileName = "Test"
.FilterIndex = 1
If .Show = -1 Then
Application.Wait Now + TimeValue("0:00:02")
On Error Resume Next
Dialog.Execute
If Err = -2147467259 Then GoTo errorhandler
End If
End With
Exit Sub
errorhandler:
Application.ScreenUpdating = True
Application.CutCopyMode = False
MsgBox "Excel kann die Datei nicht unter dem Namen einer bereits geöffneten Datei speichern."
End Sub

4
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Grafiken per VBA kopieren: .Top Eigenschaft
15.04.2019 09:54:25
Nepumuk
Hallo Sophie,
benutze nicht die Top/Left - Eigenschaft der kopierten Grafik sondern die Top/Left - Eigenschaft der TopLeftCell - Eigenschaft der kopierten Grafik.
Nach dem Muster:
NeueGrafik.Top = Worksheets("NeueTabelle").Range(AlteGrafik.TopLeftCell.Address).Top
NeueGrafik.Left = Worksheets("NeueTabelle").Range(AlteGrafik.TopLeftCell.Address).Left

Wobei "Neue" die eingefügte Grafik auf deren Tabellenblatt ist, "Alte" die kopierte Grafik.
Gruß
Nepumuk
AW: Grafiken per VBA kopieren: .Top Eigenschaft
15.04.2019 10:54:30
PinkPanther
Hallo Nepomuk,
vielen Dank für deine Antwort.
Dein Code ließt die Position leider nur für die Grafiken korrekt aus, die auch in einer Zellecke beginnen. Alle Grafiken, die "irgendwo" in einer Zelle beginnen werden damit leider nicht mehr korrekt positioniert (siehe Punkt 5).
Gibt es denn wirklich keine Möglichkeit die Top Eigenschaft mit korrekter Skalierung zu verwenden?
Danke und Lg Sophie
Anzeige
AW: Grafiken per VBA kopieren: .Top Eigenschaft
15.04.2019 13:23:42
Nepumuk
Hallo Sophie,
hier mal ein Beispiel für eine einzelne Grafik:
Public Sub Beispiel()
    Dim objSourceSheet As Worksheet, objTargetSheet As Worksheet
    Dim objSourceShape As Shape
    Dim sngLeft As Single, sngTop As Single
    Dim lngColumn As Long, lngRow As Long
    Set objSourceSheet = Worksheets("Tabelle1") 'Quelle anpassen !!!
    Set objTargetSheet = Worksheets("Tabelle2") 'Ziel anpassen !!!
    Set objSourceShape = objSourceSheet.Shapes("Grafik 1")
    With objSourceShape
        sngLeft = (.TopLeftCell.Left - .Left) * -1 + ( _
            objTargetSheet.Columns(.TopLeftCell.Column).ColumnWidth / _
            .TopLeftCell.ColumnWidth) * .TopLeftCell.ColumnWidth
        sngTop = (.TopLeftCell.Top - .Top) * -1 + ( _
            objTargetSheet.Rows(.TopLeftCell.Row).RowHeight / _
            .TopLeftCell.RowHeight) * .TopLeftCell.RowHeight
        lngColumn = .TopLeftCell.Column
        lngRow = .TopLeftCell.Row
        Call .Copy
    End With
    DoEvents
    With objTargetSheet
        Call .Paste
        .Shapes(1).Left = .Columns(lngColumn).Left + sngLeft
        .Shapes(1).Top = .Rows(lngRow).Top + sngTop
    End With
End Sub

Gruß
Nepumuk
Anzeige
Denkfehler
15.04.2019 13:40:18
Nepumuk
Hallo Sophie,
so ist's richtig:
Public Sub Beispiel()
    Dim objSourceSheet As Worksheet, objTargetSheet As Worksheet
    Dim objSourceShape As Shape
    Dim sngLeft As Single, sngTop As Single
    Dim lngColumn As Long, lngRow As Long
    Set objSourceSheet = Worksheets("Tabelle1") 'Quelle anpassen !!!
    Set objTargetSheet = Worksheets("Tabelle2") 'Ziel anpassen !!!
    Set objSourceShape = objSourceSheet.Shapes("Grafik 1")
    With objSourceShape
        sngLeft = (.TopLeftCell.Left - .Left) * -1 * ( _
            objTargetSheet.Columns(.TopLeftCell.Column).Width / .TopLeftCell.Width)
        sngTop = (.TopLeftCell.Top - .Top) * -1 * ( _
            objTargetSheet.Rows(.TopLeftCell.Row).Height / .TopLeftCell.Height)
        lngColumn = .TopLeftCell.Column
        lngRow = .TopLeftCell.Row
        Call .Copy
    End With
    DoEvents
    With objTargetSheet
        Call .Paste
        .Shapes(1).Left = .Columns(lngColumn).Left + sngLeft
        .Shapes(1).Top = .Rows(lngRow).Top + sngTop
    End With
End Sub

Gruß
Nepumuk
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige