AW: 2 Sheets separat Speichern ohne Makros
21.05.2012 16:09:21
fcs
Hallo Axel,
der etwas einfachere Weg die Makros nach dem Kopieren zu entfernen besteht darin, die Makrosichheitseinstellungen anzupassen und den Zugriff auf das VBA-Projekt zu erlauben. Dann kann man VBA-Code direkt per VBA manipulieren.
Der etwas umständlichere Weg ist, nicht die kompletten Blätter zu kopieren, sondern in der neuen Mappe leere Blätter anzulegen und dann Formate und Daten in mehreren Schritten zu kopieren. Das dauert erheblich länger, da insbesondere die Anpassung der Einstellungen unter "Seite einrichten viel Zeit benötigt.
Hier entsprechende Makros.
Gruß
Franz
für Variante 1:
'Unter Extras-->Verweise im VBA-Editor muss für die Datei der Verweis auf
' "Visual Basic for Applications Extensibillity x.y" gesetzt sein
Sub CopySheetsDeleteVBAProject()
Dim wbAktiv As Workbook, wksData As Worksheet
Dim wbNeu As Workbook
Dim strFileName As String
Const bolCloseNewFile As Boolean = False
Set wbAktiv = ActiveWorkbook
Set wksData = wbAktiv.Worksheets("Tabelle001") 'Tabellenblatt mit den Zellen für die _
Dateinamen
With wksData
strFileName = .Range("A2").Text & .Range("A3").Text & .Range("A4").Text _
& .Range("A5").Text
End With
Application.ScreenUpdating = False
wbAktiv.Worksheets(Array("TabelleABC", "TabelleXYZ")).Copy
Set wbNeu = ActiveWorkbook
Application.DisplayAlerts = False
wbNeu.SaveAs Filename:=strFileName, addtomru:=True
Application.DisplayAlerts = True
If MsgBox(Prompt:="VBA-Projekt in Mappe """ & wbNeu.Name & """ löschen?", _
Buttons:=vbYesNo + vbQuestion + vbDefaultButton2, _
Title:="VBA-Projekt in Arbeitsmappe löschen") = vbYes Then
Call fncRemoveVBA_project(wb:=wbNeu)
End If
If bolCloseNewFile = True Then
wbNeu.Close savechanges:=True
Else
wbNeu.Save
End If
Application.ScreenUpdating = True
' MsgBox "Fertig"
Set wbAktiv = Nothing: Set wksData = Nothing
Set wbNeu = Nothing
End Sub
'Prozedur erstellt unter Excel 2003
Function fncRemoveVBA_project(wb As Workbook) As Long
'Gesamten Code und Module der Arbeitsmappe löschen
'Zur Ausführung der Prozedur muss:
'1. Im VBA-Editor unter Extras--> Verweise... _
der Verweis auf die _
Microsoft Visual Basic for Applications Extensibility x.x _
aktiviert werden
'2. In Excel unter Extras --> Optionen --> Sicherheit --> Makrosicherheit _
die Option "Zugriff auf das VB-Projekt vertrauen" aktiviert werden.
Dim objVBA_Project As VBIDE.VBProject, objVBComponent As VBIDE.VBComponent
On Error GoTo Fehler
Set objVBA_Project = wb.VBProject
With objVBA_Project
For Each objVBComponent In .VBComponents
Select Case objVBComponent.Type
Case 1, 2, 3 'allgemeine Module, Klassen-Module und Userforms
.VBComponents.Remove .VBComponents(objVBComponent.Name)
Case 100 'Tabllen und DieseArbeitsmappe
With objVBComponent.CodeModule
.DeleteLines 1, .CountOfLines
End With
End Select
Next
End With
Err.Clear
Fehler:
With Err
If .Number 0 Then
fncRemoveVBA_project = .Number
Select Case .Number
Case 1004
MsgBox "Fehler: " & .Number & vbLf & .Description & vbLf _
& "Vor Start des Makros unter Optionen ""Sicherheit --> " _
& "Makrosicherheit"" Option " _
& """Zugriff auf das VB-Projekt vertrauen"" aktivieren!"
Case Else
MsgBox "Fehler: " & .Number & vbLf & .Description
End Select
End If
End With
End Function
für Variante 2
Sub CopySheetsNoMakros()
Dim wbAktiv As Workbook, wksData As Worksheet
Dim wbNeu As Workbook
Dim strFileName As String
Const bolCloseNewFile As Boolean = False
Set wbAktiv = ActiveWorkbook
Set wksData = wbAktiv.Worksheets("Tabelle001") 'Tabellenblatt mit den Zellen für die _
Dateinamen
With wksData
strFileName = .Range("A2").Text & .Range("A3").Text & .Range("A4").Text & .Range("A5"). _
Text
End With
Application.ScreenUpdating = False
'Leer-Tabellenblatt in aktiver Mappe anlegen und in neue Datei verschieben
With wbAktiv
.Worksheets.Add Before:=.Sheets(1)
.Sheets(1).Move
End With
Set wbNeu = ActiveWorkbook
'2. Blatt in neuer Mappe anlegen
wbNeu.Worksheets(1).Copy after:=wbNeu.Sheets(1)
'Blattdaten/Formate und Einstellung aus Seite Einrichten übertragen.
Call prcTransferdata(wksQ:=wbAktiv.Worksheets("TabelleABC"), wksZ:=wbNeu.Worksheets(1))
Call prcTransferdata(wksQ:=wbAktiv.Worksheets("TabelleXYZ"), wksZ:=wbNeu.Worksheets(2))
wbNeu.SaveAs Filename:=strFileName, addtomru:=True
If bolCloseNewFile = True Then
wbNeu.Close savechanges:=True
End If
Application.ScreenUpdating = True
MsgBox "Fertig"
Set wbAktiv = Nothing: Set wksData = Nothing
Set wbNeu = Nothing
End Sub
Sub prcTransferdata(wksQ As Worksheet, wksZ As Worksheet)
Dim neuPageSetup As PageSetup
With wksQ
With .UsedRange
.EntireColumn.Copy
wksZ.Cells(1, .Column).PasteSpecial Paste:=xlFormats
.EntireRow.Copy Destination:=wksZ.Cells(.Row, 1)
End With
wksZ.Name = .Name
Set neuPageSetup = wksZ.PageSetup
With .PageSetup
neuPageSetup.Orientation = .Orientation
neuPageSetup.HeaderMargin = .HeaderMargin
neuPageSetup.FooterMargin = .FooterMargin
neuPageSetup.TopMargin = .TopMargin
neuPageSetup.BottomMargin = .BottomMargin
neuPageSetup.LeftMargin = .LeftMargin
neuPageSetup.RightMargin = .RightMargin
neuPageSetup.LeftFooter = .LeftFooter
neuPageSetup.CenterFooter = .CenterFooter
neuPageSetup.RightFooter = .RightFooter
neuPageSetup.LeftHeader = .LeftHeader
neuPageSetup.CenterHeader = .CenterHeader
neuPageSetup.RightHeader = .RightHeader
neuPageSetup.PrintArea = .PrintArea
neuPageSetup.PrintTitleRows = .PrintTitleRows
neuPageSetup.PrintTitleColumns = .PrintTitleColumns
neuPageSetup.PrintGridlines = .PrintGridlines
End With
End With
End Sub