AW: Kopie einer Tabelle in neues File exportieren
29.11.2019 15:19:14
fcs
Hallo Richi,
das Kopieren des Tabellenblatts solte mit folgendem Makro funktionieren. Passwörter muss du ggf im Code ergänzen.
Das Blatt wird zunächst innerhalb der Arbeitsmappe kopiert. Dann werden die Formeln durch Werte ersetzt.
Anschliessend wird das kopierte Blatt in eine neue Mappe verschoben.
Das Blatt wird umbenannt und die Datei wird gespeichert im gleichen Ordner wie die Quelldatei.
Die Laufzeit des Kopiermakros ist relativ lang - vermutlich wegen der Vielahl an Kommentaren oder Excels-Verzuch die externen Verknüpfungen in den bedingten Formatierungen aufzubauen..
Die bedingten Formatierungen gehen wahrscheinlich verloren. Das lässt sich auch nur schwierig bereinigen denn die Zellfarbe, die von der bedingten Formatierung komt kann nicht direkt abgefragt werden.
Es glit noch anzumerken, wenn ich die Tabelle mit dem bestehenden Kopierfunktion (Kopie Tabelle in neue Arbeitsmappe) lade, kann ich das neue File nicht Speichern.
Damit kann ich nichts anfangen. Das liegt möglichweise an irgendwechen Schutzeinstellungen.
LG
Franz
Sub Tabelenblatt_kopieren()
Dim wkb_Q As Workbook, wkb_Z As Workbook
Dim wks_Q As Worksheet, wks_Z As Worksheet
Dim strFilename As String
Dim StatusCalc As Long
Dim bolwbProtedStructur As Boolean
Dim bolwbProtedWindows As Boolean
Set wkb_Q = ActiveWorkbook
Set wks_Q = wkb_Q.Worksheets("Tabelle1") 'Name anpassen !
With Application
.ScreenUpdating = False
StatusCalc = .Calculation
.Calculation = xlCalculationManual
.EnableEvents = False
.Calculate
End With
bolwbProtedStructur = wkb_Q.ProtectStructure
bolwbProtedWindows = wkb_Q.ProtectWindows
If (bolwbProtedStructur = True Or bolwbProtedWindows = True) Then _
wkb_Q.Protect Password:="", Structure:=False, Windows:=False
wks_Q.Copy after:=wkb_Q.Worksheets(wkb_Q.Sheets.Count)
Set wks_Z = wkb_Q.Worksheets(wkb_Q.Sheets.Count)
With wks_Z
.Unprotect Password:="" 'ggf. Passwort anpassen
With .UsedRange
.Copy
.PasteSpecial Paste:=xlPasteValues
End With
.Protect Password:="" 'ggf. Passwort anpassen
.Range("A1").Select
End With
wks_Z.Move
Set wkb_Z = ActiveWorkbook
wkb_Z.Worksheets(1).Name = wks_Q.Name
'Deutsche/ISO Kalenderwoche
strFilename = wkb_Q.Path & "\" & "abcd_" & Format(Date, "YYYY") & "_" & _
Format(Application.WorksheetFunction.IsoWeekNum(Date), "00")
'US-Kalenderwoche-1- Jan ist immer in KW 1
' strFilename = wkb_Q.Path & "\" & "abcd_" & Format(Date, "YYYY") & "_" & _
Format(Application.WorksheetFunction.WeekNum(Date), "00")
wkb_Z.SaveAs Filename:=strFilename, FileFormat:=51 'xlsx
wkb_Z.Close savechanges:=False
If (bolwbProtedStructur = True Or bolwbProtedWindows = True) Then _
wkb_Q.Protect Password:="", Structure:=bolwbProtedStructur, Windows:= _
bolwbProtedWindows
With Application
.ScreenUpdating = True
.Calculation = StatusCalc
.EnableEvents = True
End With
End Sub
