Unterordner mit einbeziehen
28.09.2006 10:09:51
volker
im folgenden Code werden Dateien eines Ordners (.LookIn = Range("D1").Value
) geöffnet gecheckt wieder geschlossen....
Ist es möglich den Code so zu ändern, dass auch Unterordner mit einbezogen werden?
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)
If VBA.FileDateTime(.FoundFiles(iCounter)) < Now - 14 Then
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
End If
Next iCounter
End With
'Application.ScreenUpdating=True
Application.DisplayAlerts = True
End Sub