Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1320to1324
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Verzeichnisse auflisten

Verzeichnisse auflisten
28.06.2013 15:56:06
Paul
Hallo miteinander,
vor einiger Zeit habt Ihr mir geholfen diese Datei zu verbessern.
https://www.herber.de/bbs/user/77827.xls
Nun eine weitere Bitte.
Ist es möglich mit dieser Datei eine Auflistung mit Verlinkung zu erzeugen bei der nur die in einem Verzeichnis beinhalteten Unterverzeichnisse in 1. Ebene ohne Dateien aufzulisten?
Würde mich über Hilfen freuen.
Danke im Voraus
Liebe Grüße
Paul

4
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Verzeichnisse auflisten
29.06.2013 13:11:40
Paul
Hallo,
ich habe inzwischen nochmal die bestehenden Beiträge gesucht und eine Datei geefunden, die eine Liste der Ordner /Verzeichnisse auflistet.
Leider fehlt die Verlinkung zu dem Ordner.
Ich weis nicht wie ich das bewerkstelligen kann.
Wer kann helfen.
Die Datei: https://www.herber.de/bbs/user/86122.xlsm
Danke für eure Unterstützung.
Paul

AW: Verzeichnisse auflisten
29.06.2013 14:14:51
Tino
Hallo,
hier mal ein Code für die Ordner aufzulisten.
Option Explicit

Sub OrdnerAuflisten()
Dim n&, OrderName$, ArAusgabe(), ArOrdner()
Static strOrdner$

strOrdner = Ordnerauswahl(strOrdner)

If strOrdner = "" Then Exit Sub
GetSubFolders ArOrdner, strOrdner, n, False
With Tabelle1 'Ausgabe Tabelle 
    Events False
    On Error GoTo ErrorHandler:
    .Range("A2", .Cells(.Rows.Count, 1)).ClearContents 'alte Daten löschen (in A1 = Überschrift) 
    If n > 0 Then
        Redim Preserve ArAusgabe(1 To Ubound(ArOrdner, 2), 1 To 1)
        For n = Lbound(ArOrdner, 2) To Ubound(ArOrdner, 2)
            'Formal für Hyperlink 
            ArAusgabe(n, 1) = "=HYPERLINK(""" & ArOrdner(0, n) & """,""" & ArOrdner(1, n) & """)"
        Next n
        'Ausgabe erste Zelle, hier A2 
        With .Range("A2").Resize(Ubound(ArAusgabe))
            .FormulaR1C1 = ArAusgabe
            .EntireColumn.AutoFit
        End With
    End If
ErrorHandler:
    Events True
End With

End Sub

Private Sub GetSubFolders(myAr, strPfad As String, LCount As Long, booSubFolder As Boolean, Optional FSO As Object)
Dim FO As Object, FU As Object, F As Object

If FSO Is Nothing Then Set FSO = CreateObject("Scripting.FileSystemObject")
Set FO = FSO.GetFolder(strPfad)
Set FU = FO.SubFolders

On Error GoTo ErrZugriff: 'falls zugriff verweigert 
    
    For Each F In FU
      If F.Attributes = 16 Then
        LCount = LCount + 1
        Redim Preserve myAr(1 To 2, 1 To LCount)
        myAr(0, LCount) = F.Path
        myAr(1, LCount) = F.Name
        If booSubFolder Then GetSubFolders myAr, F.Path, LCount, booSubFolder, FSO
      End If
    Next

ErrZugriff:
End Sub

'Für Dialog Ordnerauswahl 
Public Function Ordnerauswahl(Optional ByVal strVorgabe$) As String
    Dim strOrdner As String
    If strVorgabe = "" Then
        strVorgabe = "C:\"
    End If
    strVorgabe = strVorgabe & IIf(Right$(strVorgabe, 1) = "\", "", "\")
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = strVorgabe
        .Title = "Ordnerauswahl"
        .ButtonName = "Auswahl..."
        .InitialView = msoFileDialogViewList
        If .Show = -1 Then
            strOrdner = .SelectedItems(1)
            If Right(strOrdner, 1) <> "\" Then strOrdner = strOrdner & "\"
        Else
            strOrdner = ""
        End If
    End With
    Ordnerauswahl = strOrdner
End Function

Sub Events(booOn As Boolean)
Static AltCalc%
With Application
    If Not booOn Then AltCalc = .Calculation
    .ScreenUpdating = booOn
    .EnableEvents = booOn
    .Calculation = IIf(booOn, AltCalc, xlCalculationManual)
End With
End Sub
Gruß Tino

Anzeige
noch ein Fehler (sorry)...
29.06.2013 14:17:54
Tino
Hallo,
so ist es richtig.
Option Explicit

Sub OrdnerAuflisten()
Dim n&, OrderName$, ArAusgabe(), ArOrdner()
Static strOrdner$

strOrdner = Ordnerauswahl(strOrdner)

If strOrdner = "" Then Exit Sub
GetSubFolders ArOrdner, strOrdner, n, False
With Tabelle1 'Ausgabe Tabelle 
    Events False
    On Error GoTo ErrorHandler:
    .Range("A2", .Cells(.Rows.Count, 1)).ClearContents 'alte Daten löschen (in A1 = Überschrift) 
    If n > 0 Then
        Redim Preserve ArAusgabe(1 To Ubound(ArOrdner, 2), 1 To 1)
        For n = Lbound(ArOrdner, 2) To Ubound(ArOrdner, 2)
            'Formal für Hyperlink 
            ArAusgabe(n, 1) = "=HYPERLINK(""" & ArOrdner(1, n) & """,""" & ArOrdner(2, n) & """)"
        Next n
        'Ausgabe erste Zelle, hier A2 
        With .Range("A2").Resize(Ubound(ArAusgabe))
            .FormulaR1C1 = ArAusgabe
            .EntireColumn.AutoFit
        End With
    End If
ErrorHandler:
    Events True
End With

End Sub

Private Sub GetSubFolders(myAr, strPfad As String, LCount As Long, booSubFolder As Boolean, Optional FSO As Object)
Dim FO As Object, FU As Object, F As Object

If FSO Is Nothing Then Set FSO = CreateObject("Scripting.FileSystemObject")
Set FO = FSO.GetFolder(strPfad)
Set FU = FO.SubFolders

On Error GoTo ErrZugriff: 'falls zugriff verweigert 
    
    For Each F In FU
      If F.Attributes = 16 Then
        LCount = LCount + 1
        Redim Preserve myAr(1 To 2, 1 To LCount)
        myAr(1, LCount) = F.Path
        myAr(2, LCount) = F.Name
        If booSubFolder Then GetSubFolders myAr, F.Path, LCount, booSubFolder, FSO
      End If
    Next

ErrZugriff:
End Sub

'Für Dialog Ordnerauswahl 
Public Function Ordnerauswahl(Optional ByVal strVorgabe$) As String
    Dim strOrdner As String
    If strVorgabe = "" Then
        strVorgabe = "C:\"
    End If
    strVorgabe = strVorgabe & IIf(Right$(strVorgabe, 1) = "\", "", "\")
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = strVorgabe
        .Title = "Ordnerauswahl"
        .ButtonName = "Auswahl..."
        .InitialView = msoFileDialogViewList
        If .Show = -1 Then
            strOrdner = .SelectedItems(1)
            If Right(strOrdner, 1) <> "\" Then strOrdner = strOrdner & "\"
        Else
            strOrdner = ""
        End If
    End With
    Ordnerauswahl = strOrdner
End Function

Sub Events(booOn As Boolean)
Static AltCalc%
With Application
    If Not booOn Then AltCalc = .Calculation
    .ScreenUpdating = booOn
    .EnableEvents = booOn
    .Calculation = IIf(booOn, AltCalc, xlCalculationManual)
End With
End Sub
Gruß Tino

Anzeige
AW: noch ein Fehler (sorry)...
29.06.2013 14:29:57
Paul
Hallo Tino,
herzlichen Dank. Funktioniert prima.
Gruß Paul

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige