Inhaltsverzeichnis von OneDrive Ordner

Option Explicit
Dim Fso As Object, strFolders() As String, varListe() As String
Sub FileListe()
Dim LCount As Long, CountFiles As Long, LColum As Long
Dim strPath As String, OrdnerName As String, sMerkOrdnername As String
Dim strPathTemp As String
Dim rngErste As Range, tempErste As Range, rngLetzte As Range
Dim iCalc As Integer
Dim booLauf As Boolean, booErster As Boolean
Dim RowGr() As Long, a As Long
Dim aktiveTab As Worksheet
strPath = ThisWorkbook.Path
If strPath = "" Then Exit Sub
strPath = IIf(Right$(strPath, 1) = "\", strPath, strPath & "\")
strPathTemp = IIf(Right$(strPath, 1) = "\", Left$(strPath, Len(strPath) - 1), strPath)
With Application
.ScreenUpdating = False
.EnableEvents = False
iCalc = .Calculation
.Calculation = xlCalculationManual
'ab welcher Zeile einfügen
Set Fso = CreateObject("Scripting.FileSystemObject")
ReDim Preserve strFolders(0): strFolders(0) = strPath
'Ordner Listen, False = ohne Systemdateien
ListSubFolder strPath, False
With ActiveSheet
'Tabelle vorbereiten_________________________
Set aktiveTab = ActiveSheet
.Activate
Range("A2", Cells(Rows.Count, Columns.Count)).Clear 'vorhandene Daten löschen
Cells.ClearOutline
'Optionen für Gruppierung setzen
With ActiveSheet.Outline
.AutomaticStyles = False
.SummaryRow = xlAbove
.SummaryColumn = xlLeft
End With
'___________________________________________
For LCount = LBound(strFolders) To UBound(strFolders)
'Dateien im Orner Listen
FileInFolder (CStr(strFolders(LCount)))
OrdnerName = Replace(strFolders(LCount), strPath, "")
If InStr(OrdnerName, "\") > 0 Then
OrdnerName = strPath & Left$(OrdnerName, InStr(OrdnerName, "\"))
Else
OrdnerName = strFolders(LCount)
End If
'Ordnername
OrdnerName = IIf(Right$(OrdnerName, 1) = "\", OrdnerName, OrdnerName & "\")
'erster Durchlauf **************************************************************************************
If Not booLauf Then
Set rngErste = Range("A2")
'Odnername Merken für nächsten Durchlauf
sMerkOrdnername = OrdnerName
'Ordnername + Formatierung*************
rngErste = OrdnerName
rngErste.Font.Bold = True: rngErste.Font.ColorIndex = 4
'Ordnername + Formatierung + Dateien schreiben
If varListe(0)  "KeinZugriff:" Or varListe(0) = "KeineDateien:" Then
rngErste.Offset(1, 0) = Replace(strFolders(LCount), strPathTemp, ".")
rngErste.Offset(1, 0).Font.Bold = True: rngErste.Offset(1, 0).Font.ColorIndex = 15
rngErste.Offset(2, 0).Resize(UBound(varListe) + 1).Formula = Application.Transpose(varListe)
Set rngLetzte = Cells(Cells.Find("*", , xlValues, 1, 1, xlPrevious, False, False, False).Row, 1)
Range(rngErste.Offset(2, 0), rngLetzte).Rows.Group
ReDim Preserve RowGr(a): RowGr(a) = rngLetzte.Row - 1: a = a + 1
End If
'Kein Zulassung, gesperrter Odner
Set tempErste = Cells(Cells.Find("*", , xlValues, 1, 1, xlPrevious, False, False, False).Row + 1, 1)
Set rngErste = rngLetzte.Offset(1, 0)
Else 'zweiter Durchlauf *******************************************************************************
If OrdnerName  sMerkOrdnername Then
rngErste = Replace(OrdnerName, strPathTemp, ".")
Set tempErste = rngErste
rngErste.Font.Bold = True: rngErste.Font.ColorIndex = 15
'Ordnername + Formatierung + Dateien schreiben *******************************************************
rngErste.Offset(1, 1) = Replace(strFolders(LCount), strPathTemp, ".")
rngErste.Offset(1, 1).Font.Bold = True: rngErste.Offset(1, 1).Font.ColorIndex = 16
rngErste.Offset(2, 1).Resize(UBound(varListe) + 1).Formula = Application.Transpose(varListe)
Set rngLetzte = Cells(Cells.Find("*", , xlValues, 1, 1, xlPrevious, False, False, False).Row, 1)
'Gruppieren*******************************************************************************************
Range(rngErste.Offset(2, 0), rngLetzte).Rows.Group
ReDim Preserve RowGr(a): RowGr(a) = rngLetzte.Row - 1: a = a + 1
'prüfe ob letzter Ordner ereicht
If UBound(strFolders) >= LCount + 1 Then
'püfen ob nächster Ordner gleich aktueller Ordner
If Not strFolders(LCount + 1) Like OrdnerName & "*" Then
'Gruppieren*******************************************************************************************
Range(tempErste.Offset(1, 0), rngLetzte).Rows.Group
'Gruppe merken um diese zu schließen
ReDim Preserve RowGr(a): RowGr(a) = tempErste.Row: a = a + 1
End If
End If
Set rngErste = rngLetzte.Offset(1, 0)
Else 'Ordner ist angelegt ******************************************************************************
rngErste.Offset(0, 1) = Replace(strFolders(LCount), strPathTemp, ".")
rngErste.Offset(0, 1).Font.Bold = True: rngErste.Offset(0, 1).Font.ColorIndex = 16
rngErste.Offset(1, 1).Resize(UBound(varListe) + 1).Formula = Application.Transpose(varListe)
Set rngLetzte = Cells(Cells.Find("*", , xlValues, 1, 1, xlPrevious, False, False, False).Row, 1)
'Gruppieren*********************************************************************************************
Range(rngErste.Offset(1, 0), rngLetzte).Rows.Group
'Gruppe merken um diese zu schließen*******************************************************************
ReDim Preserve RowGr(a): RowGr(a) = rngLetzte.Row - 1: a = a + 1
Set rngErste = rngLetzte.Offset(1, 0)
'püfen ob nächster Ordner gleich aktueller Ordner******************************************************
If UBound(strFolders) >= LCount + 1 Then
If Not strFolders(LCount + 1) Like OrdnerName & "*" Then
'Gruppieren*******************************************************************************************
Range(tempErste.Offset(1, 0), rngLetzte).Rows.Group
'Gruppe merken um diese zu schließen
ReDim Preserve RowGr(a): RowGr(a) = tempErste.Row: a = a + 1
End If
End If
End If
sMerkOrdnername = OrdnerName
End If
booLauf = True
Erase varListe
Next LCount
Range(tempErste.Offset(1, 0), rngLetzte).Rows.Group
ReDim Preserve RowGr(a)
RowGr(a) = tempErste.Row
a = a + 1
If Range("A2") = strPath Then
Range("A3", rngLetzte).Rows.Group
End If
'Gruppen schließen
Set rngLetzte = Cells(.Rows.Count, 1).End(xlUp)
For a = LBound(RowGr) To UBound(RowGr)
ExecuteExcel4Macro "SHOW.DETAIL(1," & RowGr(a) & ",FALSE)"
Next a
End With 'Tabelle1
aktiveTab.Activate
.Calculation = iCalc
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Private Sub FileInFolder(strFolder$)
Dim Ordner As Object, varDatei As Object
Dim i As Integer
Set Ordner = Fso.GetFolder(strFolder)
On Error GoTo KeinZugriff:
If Ordner.Files.Count = 0 Then
ReDim Preserve varListe(0)
varListe(0) = "KeineDateien:"
Exit Sub
End If
For Each varDatei In Ordner.Files
ReDim Preserve varListe(i)
varListe(i) = "=HYPERLINK(""" & varDatei & """,""" & varDatei.Name & """)"
i = i + 1
Next varDatei
Exit Sub
KeinZugriff:
ReDim Preserve varListe(0)
varListe(0) = "KeinZugriff:"
End Sub
Private Sub ListSubFolder(strFolder$, Optional booSystem As Boolean = False)
Dim Unterordner As Object
Dim iVersteckt As Integer, iSystem As Integer
iSystem = IIf(booSystem, 0, 22)
On Error GoTo KeinZugriff:
For Each Unterordner In Fso.GetFolder(strFolder).SubFolders
If (Not Unterordner.Attributes = iSystem) Then
ReDim Preserve strFolders(UBound(strFolders) + 1)
strFolders(UBound(strFolders)) = CStr(Unterordner)
ListSubFolder CStr(Unterordner)
End If
Next
Exit Sub
KeinZugriff:
End Sub
Sub Loesche_Daten()
Range("A2", Cells(Rows.Count, Columns.Count)).Clear
Cells.ClearOutline
End Sub