Grafik einfügen

Hallo zusammen,
mit dem unteren Makro fehlt mir eine Grafik in der neuen Arbeitsmappe. Ich möchte aus dem Sheet("alleFonds_ohneFormel") die Grafik auch mitkopieren. Das klappt aber nicht. Wie kann ich diese mit einem Makro einfügen.
Hat da jmd. einen Tipp?
Sub neues_Sheet_oeffnen_und_Daten_kopieren()
Dim wbZiel As Workbook
Dim wsZiel As Worksheet
Dim mappenname As String
Dim gesamtname As String
Dim quellbereich As Range
Dim zielbereich As Range
Dim emailVerteiler As String
Application.ScreenUpdating = False
mappenname = "C_R_Kalender_" & Format(Date, "DD. MMMM YYYY")
Set wbZiel = Application.Workbooks.Add
Set wsZiel = wbZiel.Worksheets(1)
wsZiel.Name = mappenname
Set quellbereich = ThisWorkbook.Worksheets("alleFonds_ohne Formel").Range("A1:ab270") 'zu kopierenden Bereich definieren
Set zielbereich = wsZiel.Range("A1:ab270")
quellbereich.Copy
wsZiel.Activate
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Cells.EntireColumn.AutoFit
end
Danke.
Dani

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Sub neues_Sheet_oeffnen_und_Daten_kopieren() Dim wbZiel As Workbook Dim wsZiel As Worksheet Dim mappenname As String Dim gesamtname As String Dim quellbereich As Range Dim zielbereich As Range Dim emailVerteiler As String Dim oShape As Shape Application.ScreenUpdating = False mappenname = "C_R_Kalender_" & Format(Date, "DD. MMMM YYYY") Set wbZiel = Application.Workbooks.Add Set wsZiel = wbZiel.Worksheets(1) wsZiel.Name = mappenname Set quellbereich = ThisWorkbook.Worksheets("alleFonds_ohne Formel").Range("A1:ab270") 'zu _ kopierenden Bereich definieren Set zielbereich = wsZiel.Range("A1:ab270") quellbereich.Copy wsZiel.Activate Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _ xlNone, SkipBlanks:=False, Transpose:=False Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False Cells.EntireColumn.AutoFit 'Shapes aus dem Quellblatt kopieren und im Zielblatt einfügen. For Each oShape In ThisWorkbook.Worksheets("alleFonds_ohne Formel") oShape.Copy wsZiel.Range(oShape.TopLeftCell.Address).Select ActiveSheet.Paste 'oder Selection.Paste Next End End Sub

Hallo Franz,
vielen Dank für deine Hilfe, aber das Makro klappt nicht. Bekomme Fehlermeldung 438.
Makro bleibt in dieser Zeile stehen:
For Each oShape In ThisWorkbook.Worksheets("alleFonds_ohne Formel")
Danke.
Dani
Anbei noch einmal unten das komplette Makro:
Sub neues_Sheet_oeffnen_und_Daten_kopieren2()
Dim wbZiel As Workbook
Dim wsZiel As Worksheet
Dim mappenname As String
Dim gesamtname As String
Dim quellbereich As Range
Dim zielbereich As Range
Dim emailVerteiler As String
Dim oShape As Shape
Application.ScreenUpdating = False
mappenname = "C_R_Kalender_" & Format(Date, "DD. MMMM YYYY")
Set wbZiel = Application.Workbooks.Add
Set wsZiel = wbZiel.Worksheets(1)
wsZiel.Name = mappenname
Set quellbereich = ThisWorkbook.Worksheets("alleFonds_ohne Formel").Range("A1:ab270") 'zu _
kopierenden Bereich definieren
Set zielbereich = wsZiel.Range("A1:ab270")
quellbereich.Copy
wsZiel.Activate
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Cells.EntireColumn.AutoFit
'Shapes aus dem Quellblatt kopieren und im Zielblatt einfügen.
For Each oShape In ThisWorkbook.Worksheets("alleFonds_ohne Formel")
oShape.Copy
wsZiel.Range(oShape.TopLeftCell.Address).Select
ActiveSheet.Paste 'oder Selection.Paste
Next
'Formatierung
ActiveWindow.DisplayGridlines = False
Columns("A:b").ColumnWidth = 10.14
Columns("c:ab").ColumnWidth = 23.43
Columns("ab:ab").EntireColumn.AutoFit
Rows("3:3").Select
Rows("3:3").EntireRow.AutoFit
With ActiveSheet.PageSetup
.PrintArea = "$A$1:$ab$270"
.CenterHorizontally = True
.CenterVertically = True
.Orientation = xlPortrait
.Draft = False
.PaperSize = xlPaperA4
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
.PrintErrors = xlPrintErrorsDisplayed
End With

Sub neues_Sheet_oeffnen_und_Daten_kopieren() Dim wbZiel As Workbook Dim wsZiel As Worksheet dim wsquelle as worksheet Dim mappenname As String Dim gesamtname As String Dim quellbereich As Range Dim zielbereich As Range Dim emailVerteiler As String Application.ScreenUpdating = False set wsquelle = Activesheet mappenname = "C_R_Kalender_" & Format(Date, "DD. MMMM YYYY") Set wbZiel = Application.Workbooks.Add Set wsZiel = wbZiel.Worksheets(1) wsZiel.Name = mappenname Set quellbereich = ThisWorkbook.Worksheets("alleFonds_ohne Formel").Range("A1:ab270") 'zu _ kopierenden Bereich definieren Set zielbereich = wsZiel.Range("A1:ab270") quellbereich.Copy wsZiel.Activate Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _ xlNone, SkipBlanks:=False, Transpose:=False Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False Cells.EntireColumn.AutoFit for i =1 to wsquelle.shapes.count wsquelle.shapes(i).copy wsziel.paste next i End Sub

Beliebteste Forumthreads (12 Monate)

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread