AW: VBA Unterordner einbeziehen
19.03.2021 14:28:28
Nepumuk
Hallo MarC,
teste mal:
Option Explicit
Public Sub Auslesen()
Dim strDateiname As String
Dim strVerzeichnis As String
Dim i As Long
Dim astrFolders() As String
Dim ialngFolders As Long
Dim objWorkbook As Workbook
strVerzeichnis = GetFolder & "\"
If strVerzeichnis <> "\" Then
Application.ScreenUpdating = False
astrFolders = GetFolders(strVerzeichnis)
For ialngFolders = LBound(astrFolders) To UBound(astrFolders)
strDateiname = Dir$(astrFolders(ialngFolders) & "*.xls*")
Do Until strDateiname = vbNullString
Set objWorkbook = Workbooks.Open(Filename:=astrFolders(ialngFolders) & strDateiname)
With objWorkbook.Worksheets("Tabelle1")
For i = 7 To .Cells(.Rows.Count, 3).End(xlUp).Row
If Date > DateAdd("m", 6, .Cells(i, 3).Value) Then .Cells(i, 2).ClearContents
Next i
objWorkbook.Close SaveChanges:=True
Set objWorkbook = Nothing
End With
strDateiname = Dir$
Loop
Next
Application.ScreenUpdating = True
MsgBox "Inhalte wurden gelöscht!"
End If
End Sub
Private Function GetFolder() As String
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.InitialFileName = "D:\Test\"
.ButtonName = "Öffnen"
.Title = "Ordnerauswahl"
If .Show Then GetFolder = .SelectedItems(1)
End With
End Function
Private Function GetFolders(ByVal pvstrPath As String) As String()
Dim astrFolders() As String
Dim strFolder As String, strPath As String
Dim ialngIndex1 As Long, ialngIndex2 As Long
Redim Preserve astrFolders(ialngIndex1)
astrFolders(ialngIndex1) = pvstrPath
ialngIndex1 = 1
ialngIndex2 = 1
strPath = pvstrPath
Do
strFolder = Dir$(PathName:=strPath & "*", Attributes:=vbDirectory)
Do Until strFolder = vbNullString
If strFolder <> "." And strFolder <> ".." Then
If GetAttr(PathName:=strPath & strFolder) And vbDirectory Then
Redim Preserve astrFolders(0 To ialngIndex1)
astrFolders(ialngIndex1) = strPath & strFolder & "\"
ialngIndex1 = ialngIndex1 + 1
End If
End If
strFolder = Dir$
Loop
If ialngIndex1 = ialngIndex2 Then Exit Do
strPath = astrFolders(ialngIndex2)
ialngIndex2 = ialngIndex2 + 1
Loop
GetFolders = astrFolders
End Function
Gruß
Nepumuk