makro Start nach Datum
26.09.2006 10:39:31
volker
mal wieder brauch ich Hilfe.
Mit folgendem makro lasse ich unbenötigte Sheets löschen.
Nun soll das makro noch so verfeinert werden, dass nur Dateien bei denen seit dem letzen speichern 2 Wochen vergangen sind, behandelt werden.
Wäre nett wenn mir das jemand machen könnte,
Danke Gruss volker
Sub BlätterLöschen()
'Dateien öffnen
Dim wks As Worksheet
Dim fs As FileSearch
Dim lRow As Long
Dim iCounter As Integer
'Application.ScreenUpdating= false
Application.DisplayAlerts = False
Set fs = Application.FileSearch
lRow = 3
'lRow = InputBox("Zeilen Nr. angeben")
With fs
.Filename = "*.xls"
.LookIn = Range("D1").Value
.Execute
For iCounter = 1 To .FoundFiles.Count
'Cells(lRow, 1).Value = .FoundFiles(iCounter)
lRow = lRow
Workbooks.Open .FoundFiles(iCounter)
'unbeschriebene Beschlaglisten löschen
For Each wks In ActiveWorkbook.Worksheets
With wks
Select Case .Name
Case "Holzliste", "Zeiten", "Laufkarte"
'do nothing
Case "BL Container"
If Application.WorksheetFunction.CountA(.Range("A7:A32")) < 1 Then
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
End If
Case "BL Conside"
If Application.WorksheetFunction.CountA(.Range("A7:A15"), .Range("A38"), .Range("A40:A60")) < 1 Then
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
End If
Case "BL Depona"
If Application.WorksheetFunction.CountA(.Range("A7:A15"), .Range("A40:A60")) < 1 Then
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
End If
Case "BL K4"
If Application.WorksheetFunction.CountA(.Range("A7:A17"), .Range("A21:A31"), .Range("A38:A40"), .Range("A46:A62")) < 1 Then
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
End If
Case "BL Kabinentrennwand"
If Application.WorksheetFunction.CountA(.Range("A7:A18"), .Range("A21:A26")) < 1 Then
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
End If
Case "BL ComWagen"
If Application.WorksheetFunction.CountA(.Range("A8:A31"), .Range("A39:A62")) < 1 Then
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
End If
Case Else
If Application.WorksheetFunction.CountA(.Range("A7:A31"), .Range("A39:A64")) < 1 Then
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
End If
End Select
End With
Next wks
ActiveWorkbook.Close savechanges:=True
'Application.Wait Now + 5 / 86400
Next iCounter
End With
'Application.ScreenUpdating=True
Application.DisplayAlerts = True
End Sub