Mit dem folgenden excel Macro code kann man per vba die Farben und Designeinstellungen einer Excel Arbeitsmappe auf eine andere Excel Datei übertragen
workbook_Export.ApplyTheme wb.FullName |
Option Explicit
'***********< Ausgabe >**************** '*Ausgabe_Datei erstellen
Public Const °Ausgabeordner = "07_Ausgabe"
Public Sub AusgabeDatei_erstellen() '-----------------< AusgabeDatei_erstellen() >----------------- '< active Workbook > Dim wb As Workbook Set wb = ActiveWorkbook '</ active Workbook >
'< check_Ordner > Application.StatusBar = Now & " check Ausgabeordner: " & ThisWorkbook.Path & "\" & °Ausgabeordner
Dim fs As FileSystemObject Set fs = New FileSystemObject If fs.FolderExists(ThisWorkbook.Path & "\" & °Ausgabeordner) = False Then fs.CreateFolder ThisWorkbook.Path & "\" & °Ausgabeordner 'erstellen End If Set fs = Nothing '</ check_Ordner >
'----< AusgabeDatei_erstellen >---- Application.StatusBar = Now & " erstelle Ausgabedatei.." DoEvents Application.ScreenUpdating = False
'< delete_sheet1 > Dim workbook_Export As Workbook Set workbook_Export = Workbooks.Add()
'< Design-Farb-Schema uebernehmen > workbook_Export.ApplyTheme wb.FullName '</ Design-Farb-Schema uebernehmen >
Application.DisplayAlerts = False '*suppress alert: delete sheet1 und save.overwrite '</ delete_sheet1 >
'----< Sheets ermitteln >---- Dim ws As Worksheet
'--< @Loop: alle Sheets >-- For Each ws In wb.Sheets If ws.Visible = xlSheetVisible Then If ws.Range("A1").Value = "96dpi" Then Application.StatusBar = Now & " Ausgabeblatt:" & ws.Name Ausgabeblatt_uebertragen wb, ws, workbook_Export End If End If Next '--< @Loop: alle Sheets >--
'< save > Application.StatusBar = Now & "speichern Datei: " & workbook_Export.Name workbook_Export.SaveAs wb.Path & "\" & °Ausgabeordner & "\" & workbook_Export.Name '</ save >
Application.DisplayAlerts = False workbook_Export.Sheets(1).Delete workbook_Export.Close Set workbook_Export = Nothing Application.DisplayAlerts = True
Application.StatusBar = Now & " fertig: Datei ausgeben" '-----------------</ AusgabeDatei_erstellen() >----------------- End Sub
Public Sub Ausgabeblatt_uebertragen(ByRef wb As Workbook, ByRef ws As Worksheet, ByRef workbook_Export As Workbook) '-----------------< Eingabeblatt_einlesen() >----------------- ws.Activate
'----< Sheets ermitteln >---- Application.StatusBar = Now & " export Blatt: " & ws.Name DoEvents Application.ScreenUpdating = False
Dim wsExport As Worksheet ws.Copy Before:=workbook_Export.Sheets(1)
'< Ansicht > Set wsExport = workbook_Export.Sheets(ws.Name) workbook_Export.Activate ActiveWindow.View = xlPageBreakPreview '*Ansicht auf PrintPreview xlPageBreakPreview xlLandscape xlNormalView '</ Ansicht >
'##--< Export_Anpassen >--## Zeilen_Spalten_auf_Blatt_einausblenden wsExport, SetAnsicht:=False
'##--</ Export_Anpassen >--##
'< close > Application.StatusBar = Now & "Datei ausgabe erledigt.: " & ws.Name '</ close >
'-----------------</ Eingabeblatt_einlesen() >----------------- End Sub |