Microsoft Excel

Herbers Excel/VBA-Archiv

Grafiken per VBA kopieren: .Top Eigenschaft


Betrifft: Grafiken per VBA kopieren: .Top Eigenschaft
von: PinkPanther
Geschrieben am: 14.04.2019 19:50:47

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

  

Betrifft: AW: Grafiken per VBA kopieren: .Top Eigenschaft
von: Nepumuk
Geschrieben am: 15.04.2019 09:54:25

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


  

Betrifft: AW: Grafiken per VBA kopieren: .Top Eigenschaft
von: PinkPanther
Geschrieben am: 15.04.2019 10:54:30

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


  

Betrifft: AW: Grafiken per VBA kopieren: .Top Eigenschaft
von: Nepumuk
Geschrieben am: 15.04.2019 13:23:42

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


  

Betrifft: Denkfehler
von: Nepumuk
Geschrieben am: 15.04.2019 13:40:18

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