问根据文件夹名称中包含的日期，返回最新的文件夹目录

EN

Option Explicit
Sub ReadStructure()
 Dim lngZeile As Long
 Dim lngSpalte As Long
 Dim strPFad As String

strPFad = ThisWorkbook.Path
 'Clear all cells form sheet 1
 sheet1.Cells.ClearContents
 sheet1.Range("A1").Value = strPFad

 lngZeile = 2

 Call ReadFilesFolder(strPFad, lngZeile, lngSpalte)

End Sub

Sub ReadFilesFolder(strPFad As String, ByRef lngZeile, ByRef lngSpalte)

 Dim oFSO As Object
 Dim objOrdner As Object
 Dim objUnterordner As Object
 Dim objDatei As Object

 Set oFSO = CreateObject("Scripting.FileSystemObject")
 Set objOrdner = oFSO.getfolder(strPFad)

 lngSpalte = lngSpalte + 1
  'Check with loop for folders
  For Each objDatei In objOrdner.Files
    lngZeile = lngZeile + 1
    sheet1.Cells(lngZeile, lngSpalte).Value = objDatei.Name
    sheet1.Cells(lngZeile, lngSpalte).Font.Bold = True
  Next objDatei

  For Each objUnterordner In objOrdner.Subfolders
   lngZeile = lngZeile + 1
   sheet1.Cells(lngZeile, lngSpalte).Value = objUnterordner.Name & "\"
   sheet1.Cells(lngZeile, lngSpalte).Font.Bold = False
   Call ReadFilesFolder(objUnterordner.Path, lngZeile, lngSpalte)

  Next objUnterordner

  lngSpalte = lngSpalte - 1

  Set oFSO = Nothing

  Exit Sub

 Fehler:
  If Err.Number = 70 Then
  lngZeile = lngZeile + 1
  sheet1.Cells(lngZeile, lngSpalte).Value = "No Acess"
  End If
  lngSpalte = lngSpalte - 1
  Set oFSO = Nothing

  End Sub