AW: Per Makro neue Mappe erstellen und speichern
21.01.2005 08:41:18
Harald
Hallo Sven,
hier eine abgespeckte Variante aus meinem Hausgebrauch. Viel Spass beim Basteln ;-))
Sub Sperrlagermonat()
'kopiert relevante Daten in neue Datei, löscht alte Daten
Info = MsgBox("Es werden die ersten 300 Zeilen in einer neuen Datei gespeichert und alte Daten gelöscht!", vbOKCancel)
If Info = vbCancel Then
Exit Sub
End If
Application.ScreenUpdating = False
ActiveSheet.Unprotect
Range("A1:D300,F1:F300,G1:G300,H1:H300,I1:I300,J1:J300").Select
Selection.Copy
Workbooks.Add
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
True, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteComments, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Columns("A:I").AutoFit
Range("C26").Select 'in dieser Zelle steht ein Datum
ChDir "C:\Eigene Dateien\Zusammenfassung 2004"
ActiveWorkbook.SaveAs Filename:= _
"MC:\Eigene Dateien\Zusammenfassung 2004\Sperrlagererfassung_" & Format(ActiveCell, "mm") & "_" & Format(ActiveCell, "yy") & ".xls", FileFormat:= _
xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False
ActiveWindow.Close
Sheets("Smart").Range("D2:AH74").ClearContents
With Sheets("Erfassung")
.Range("D26:E300,H26:H300").ClearContents
.Range("D26:E300,H26:H300").ClearComments
.Range("C26:C300").ClearContents
.Range("C26").Select
End With
Application.ScreenUpdating = True
MsgBox " Jetzt noch diese Datei mit neuem Monatsnamen abspeichern....fertich"
End Sub
Gruß
Harald