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