Office: Tabellenblatt inklusive Grafik kopieren

Hallo,

muss heute direkt ein zweites Mal um Hilfe bitten, da ich mit dem Thema Makro noch nicht so ganz
warm bin.

Ich habe ein Makro (unten mal aufgeführt), dass ein Tabellenblatt kopiert und eine neue Datei mit dem Tabellenblatt anlegt.
Jetzt habe ich im Originaltabellenblatt eine Grafik eingefügt...die aber nicht mitkopiert wird.

Wie müsste ich das Makro abändern, damit auch Grafiken mitkopiert werden...?

Danke (noch einmal)...
tobi


Hier das Makro (keine Angst...sieht wuchtig aus...ist aber harmlos:D)


Sub CopyRangfolge()
Dim rngA As Range, rngB As Range
Dim sFile As String, sPath As String
sPath = ThisWorkbook.Path & "/rangfolge.xls"
Set rngA = ActiveSheet.Range("A1:M56")
sFile = Dir(sPath)
If sFile = "" Then
Workbooks.Add
Else
Workbooks.Open sPath
End If
rngA.copy
Range("A1").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Selection.PasteSpecial Paste:=xlFormats
Columns("A:A").ColumnWidth = 5.43
Columns("B:B").ColumnWidth = 6.71
Columns("C:C").ColumnWidth = 5.86
Columns("D:D").ColumnWidth = 24.71
Columns("E:E").ColumnWidth = 9
Columns("F:F").ColumnWidth = 9
Columns("G:G").ColumnWidth = 7.71
Columns("H:H").ColumnWidth = 9.29
Columns("I:I").ColumnWidth = 9.29
Columns("J:J").ColumnWidth = 9.29
Columns("K:K").ColumnWidth = 9.29
Columns("L:L").ColumnWidth = 9.5
Columns("M:M").ColumnWidth = 10
Range("B12:B56").Select
Selection.NumberFormat = "0"
Range("C:C").Select
Selection.NumberFormat = "0.0"
Range("E12:E56").Select
Selection.NumberFormat = "#,##0.00 [$€-407]"
Range("F12:F56").Select
Selection.Style = "Currency"
Range("H12:K56").Select
Selection.NumberFormat = "0"
Range("A10:A56").Select
Selection.NumberFormat = """(""0"")"""
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.31496062992126)
.RightMargin = Application.InchesToPoints(0.31496062992126)
.TopMargin = Application.InchesToPoints(0.31496062992126)
.BottomMargin = Application.InchesToPoints(0.31496062992126)
.HeaderMargin = Application.InchesToPoints(0.511811023622047)
.FooterMargin = Application.InchesToPoints(0.511811023622047)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = -3
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlPortrait
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
.PrintErrors = xlPrintErrorsDisplayed
End With
Application.DisplayAlerts = False
Sheets(Array("Tabelle2", "Tabelle3")).Select
Sheets("Tabelle3").Activate
ActiveWindow.SelectedSheets.Delete
ActiveWorkbook.SaveAs sPath
Application.DisplayAlerts = True
Range("B7:B7").Select
Selection.NumberFormat = "0"
Range("B12:B56").Select
Selection.NumberFormat = "0"
End Sub

 

Hi Tobi,

weshalb kopierst du nicht das gesamte Tabellenblatt, erstellst damit eine neue Arbeitsmappe und löschst anschließend die nicht benötigten Zellbereiche?

Bis später,
Karin

 

Hab' ich gerade mal probiert.
Das geht natürlich auch...aber nicht so 100%ig.

Mein Makro sorgt irgendwie dafür, dass in der neuen Datei nur die Formate und Werte hineinkopiert werden. Nicht die verweise auf die Ursprungszellen.
Im Grunde funktioniert mein Makro ja zu 99,999%...einzige die Grafiken werden nicht mitkopiert.
Aber da sollte es doch auch einen Befehl geben...oder?

tobi

 

Hi Tobi,

Mit dieser deiner Aussage kann niemand etwas anfangen. Bei mir funktioniert diese Vorgehensweise 100%ig.

Bis später,
Karin

 

Sorry...hast Recht.
Ich hab' mich da ein wenig "wirr" ausgedrückt

Deshalb hier noch mal vernünftig.
Eine Beispielsdatei habe ich mal hochgeladen.
Wenn Du in ihr das Makro ausführst, wird eine neue Datei angelegt.
Alles geschieht was geschehen soll...nur die Grafik wird nicht
mitkopiert.

tobi

 

Hi Tobi,

versuche es mal so:

Code:

Sub CopyRangfolge()
   Dim wksTab As Worksheet
   Dim sFile As String, sPath As String
   sPath = ThisWorkbook.Path & "/rangfolge.xls"
   sFile = Dir(sPath)
   If sFile = "" Then
      Workbooks.Add
   Else
      Workbooks.Open sPath
      Application.DisplayAlerts = False
      For Each wksTab In ActiveWorkbook.Worksheets
         If wksTab.Name = "punktestand" Then
            wksTab.Delete
            Exit For
         End If
      Next wksTab
      Application.DisplayAlerts = False
   End If
   ThisWorkbook.Worksheets("punktestand").Copy before:=ActiveWorkbook.Sheets(1)
   Application.DisplayAlerts = False
   For Each wksTab In ActiveWorkbook.Worksheets
      If wksTab.Name <> "punktestand" Then wksTab.Delete
   Next wksTab
   ActiveWorkbook.SaveAs sPath
   Application.DisplayAlerts = True
End Sub

Bis später,
Karin

 

Hallo Beverly (Karin),

erst einmal vielen Dank dass Du zu später Stunde an meinem Problem
gebastelt hast.

Deine Lösung ist fast perfekt...

Nur eine Sachen müsste man noch ändern und da hoffe ich unverschämterweise
dass Du eventuell nochmal helfen könntest.

Dein Makro legt ja die neue Datei an. In dieser sind aber alle Werte "nur" als Verweise enthalten,
also da wo die Originaldaten liegen. In der neuen Datei sollen die Werte aber nur als Werte
enthalten sein...und natürlich mit dem richtigen Format (also das was Dein Makro ja schon macht).

Nochmals....vielen Dank für Deine Mühe.:D
tobi


Ups...
eins hatte ich noch vergessen.
Kann meine Dein Makro so abändern, dass von dem Tabellenblatt nur den Bereich A1:I50 kopiert wird?
Es stehen in dem Blatt normalerweise noch einiges mehr, was aber nicht kopiert werden soll.

 

Hi Tobi,

im Prinzip musst du den Code nur dahingehend erweitern, was du schon in deinem Code machst - Kopieren und Werte einfügen. Ergänze dazu diese beiden Zeilen

Code:

   ActiveSheet.UsedRange.Copy
   ActiveSheet.UsedRange.PasteSpecial Paste:=xlValues

nach der Zeile ThisWorkbook.Worksheets("punktestand").Copy....

Bis spter,
Karin

 

Hi Tobi,

als ich 10:20 meinen letzten Beitrag geschrieben habe, habe ich leider nicht bemerkt, dass du deinen Beitrag noch um eine Frage ergänzt hast. Nur einen Bereich als neues Tabellenblatt kopieren ist nicht möglich, aber man kann die überflüssigen Spalten/Zeilen löschen.

Code:

Sub CopyRangfolge()
   Dim wksTab As Worksheet
   Dim sFile As String, sPath As String
   Dim strSpalte As String
   sPath = ThisWorkbook.Path & "/rangfolge1.xls"
   sFile = Dir(sPath)
   If sFile = "" Then
      Workbooks.Add
   Else
      Workbooks.Open sPath
      Application.DisplayAlerts = False
      ' nur 1 Tabellenblatt vorhanden und es hat den Namen "punktestand", dann 1 leeres Tabellenblatt
      ' einfügen und Tabelle "punktestand" löschen
      If ActiveWorkbook.Worksheets.Count = 1 Then
         If Worksheets(1).Name = "punktestand" Then
            Worksheets.Add
            Worksheets("punktestand").Delete
         End If
      Else
         For Each wksTab In ActiveWorkbook.Worksheets
            If wksTab.Name = "punktestand" Then
               wksTab.Delete
               Exit For
            End If
         Next wksTab
      End If
      Application.DisplayAlerts = False
   End If
   ThisWorkbook.Worksheets("punktestand").Copy before:=ActiveWorkbook.Sheets(1)
   With ActiveSheet
      ' nach dem Kopieren des Tabellenblattes Zeilen unterhalb 50 und Spalten rechts von I löschen
      strSpalte = .Cells(1, .UsedRange.SpecialCells(xlCellTypeLastCell).Column).Address(True, False)
      strSpalte = Application.Substitute(strSpalte, "$1", "")
      .Rows("51:" & .UsedRange.SpecialCells(xlCellTypeLastCell).Row).Delete shift:=xlUp
      .Columns("I:" & strSpalte).Delete shift:=xlToRight
      ' benutzten Bereich kopieren und Werte einfügen
      .UsedRange.Copy
      .UsedRange.PasteSpecial Paste:=xlValues
   End With
   Application.DisplayAlerts = False
   For Each wksTab In ActiveWorkbook.Worksheets
      If wksTab.Name <> "punktestand" Then wksTab.Delete
   Next wksTab
   ActiveWorkbook.SaveAs sPath
   Application.DisplayAlerts = True
End Sub

Beim Testen habe ich festgestellt, dass man noch etwas berücksichtigen muss, und zwar wenn die Arbeitsmappe schon vorhanden ist. Wenn in dieser nur 1 Tabellenblatt vorhanden ist - die anderen wurden beim Speichern gelöscht und nachträglich keine weiteren eingefügt - löst dies beim Löschen dieses einen Tabellenblattes natürlich einen Fehler aus, denn eine Arbeitsmappe muss mindestens 1 Tabellenblatt enthalten. Aus diesem Grund habe ich den Code an der betreffenden Stelle geändert: es wird ein 2. Tabellenblatt eingefügt und erst anschließend Tabelle "punktestand" gelöscht.

Bis später,
Karin

 

Also...ehrlich!
Mehr Service kann ich nicht erwarten ;)

Hab' jetzt keine Zeit mehr zum Testen...werde mich aber heute abend wieder melden.

Bis später,
tobi

 

So...hab' doch noch Zeit gefunden Dein letztes Makro zu testen.

So kann ich es benutzen...macht genau was es soll.

Habe nur noch eine allerletzte Frage

Dein Makro kopiert das Ursprungstabellenblatt genau so wie es soll,
sogar die Spaltenbreite wird 1:1 übernommen (was für mich wichtig ist)...
nur bei der Spalte I wird dies nicht gemacht.
Den Grund dafür kann ich aber nicht finden...

Weißt Du warum...?
tobi

 

Stop!
Ich muss mich korrigieren.
Ich hab' das was falsch gesehen.

Das liegt daran, dass im Original die Zellen G4, H4 und I4 verbunden sind,
in der Kopie sind aber nur G4 und H4 verbunden.
Kann das an der Stelle liegen, damit alles rechts von I gelöscht wird?

tobi

 

So..jetzt ist aber Schluß!

Konnte es selbst korrigieren.
Ich habe den Eintrag von

.Columns("I:" & strSpalte).Delete shift:=xlToRight

auf

.Columns("J:" & strSpalte).Delete shift:=xlToRight

abgeändert.
Jetzt klappt's.

Vielen Dank noch einmal für Deine mühevolle Mithilfe.:)

Danke...
tobi