Copy Daten in eine best. Excel - Mappe
meixner
ich möchte aus einer Excel - Mappe eine Tabelle in eine andere Excel - Mappe kopieren. Dabei handelt es sich um eine bestimmte Excel - Mappe, die Excel CA heisst und sich unter dem Pfad:
I:\CM_88\8801\FM\Allgemeines\C_R befindet.
Das Problem ist, mit dem unteren Makro wird irgendeine Excel - Mappe aufgemacht und nicht die Excel - CA Mappe, die ich benötige.
Kann mir jmd. einen Tipp geben?
Viele Grüße
Dani
Das Makro lautet:
Sub neues_Sheet_oeffnen_und_Daten_kopieren3()
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
Dim namedatei As String
Application.ScreenUpdating = False
'Ergebnis in eine neue Datei kopieren und diese mit Datumszusatz archivieren
pfad = "I:\CM_88\8801\FM\Allgemeines\C_R\"
namedatei = "C_R Kalender " & Format(Date, "DD.MMMM YYYY") 'Name Datei bestimmen
gesamtname = pfad & namedatei & ".xls"
Set wbZiel = Application.Workbooks.Add
Set wsZiel = wbZiel.Worksheets(1)
wsZiel.Name = namedatei
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").Shapes
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:c").ColumnWidth = 19.43
Columns("d:f").ColumnWidth = 21.43
Columns("g:m").ColumnWidth = 21.43
'Columns("d:d").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
'Datei unter neuem Namen archivieren und schließen
wbZiel.SaveAs gesamtname 'abspeichern des Excel _
Sheet mit neuem Namen zur Archivierung
wbZiel.Close SaveChanges:=False
End Sub