Code Erweitern
26.05.2004 11:10:53
Dieter
benutze unten stehenden Code, der durch die Hilfe aus diesem Forum entstand.
Der Code ist soweit in Ordnung und läuft auch sehr gut.
Nun hat sich beim praktischen Arbeiten aber herausgestellt,das noch etwas daran zu verbessern wäre.
Der Code sollte noch beinhalten das ,das Blatt was abgespeichert wird keine Formeln mehr enthalten sollte.
Ich hoffe wieder mal auf eure Hilfe.
MfG Dieter
Sub Blatt1Kopieren()
Dim strPath As String
Dim strName As String
Dim strWert As String
Dim shp As Shape
ActiveSheet.Unprotect
strPath = "C:\Winnt\Profiles\xflb21\Eigene Dateien\Sicherung_xls\" 'Pfad
strName = ActiveSheet.Name 'Tabellenname
strWert = ActiveSheet.Range("A1") 'Dateiname - zusatz
Application.ScreenUpdating = False
ActiveSheet.Copy
With ActiveWorkbook
For Each shp In Sheets(1).Shapes 'Schaltflächen entfernen
shp.Delete
Next
With .VBProject.VBComponents(.VBProject.VBComponents(2).CodeModule).CodeModule
.DeleteLines 1, .CountOfLines
End With
.Sheets(1).Cells.Locked = True 'Zellen sperren
.Sheets(1).Protect "test" 'Blattschutz setzen - Passwort anpassen
.SaveAs strPath & strName & " " & Format(Date, "dd-mm-yy") & " " & _
strWert & ".xls"
MsgBox " Kopie von " & strName & " " & strWert & " wurde angelegt "
MsgBox " Das Blatt 1 wird nun gedruckt 1 Kopie"
.Close
End With
'Worksheets("Gesamt").Visible = True 'wird zZ. nicht benötigt
'Worksheets("Gesamt").PrintOut 'wird zZ. nicht benötigt
'Worksheets("Gesamt").Visible = False 'wird zZ. nicht benötigt
Application.ScreenUpdating = True
ActiveSheet.Protect
Sheets("Blatt1").Select
ActiveSheet.Unprotect
Application.ScreenUpdating = False
ActiveSheet.PageSetup.PrintArea = "$A$1:$AF$40"
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=Tr
Range("N3:P3,U3,A7:AF31,Z34,S35:S39,H34:J40") = ""
ActiveSheet.Protect
Application.ScreenUpdating = True
End Sub