Vorhandenen Code erweitern
05.08.2004 11:01:18
Dieter
Ich möchte den unten stehenden Code erweitern,und zwar möchte ich das am Ende des Codes eine Userform erscheint für etwa 40 Sekunden.
Die UF besteht bereits, nur fehlt mir die dazu gehörenden Code- Zeilen mangels VBA Kenntnis.
Kann mir jemand von euch behilflich sein ?
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
Sheets(1).Cells.Copy ' Formeln auf Copy entfrnen
Cells.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
With .VBProject.VBComponents(.VBProject.VBComponents(2).CodeModule).CodeModule 'VBA Projecte entfernen
.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
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