Ordnerstruktur

[Andyle]

Hallo liebe Forumgemeinde.

Ich suche nach ewigen Test eine Lösung für eine Auflistung

Hauptordner-> Ordnername
Hauptordner > Ordnername
Unterordner > Ordnername
Hauptordner > Ordnername
Unterordner > Ordnername
Datei


Er soll praktisch 
Hauptordner->
Unterordner > 
davorsetzen

Code:

Option Explicit
Public lRowCounter As Long
Public Ordnercount As Long

Sub Auslesen1()

Dim objShell As Object
Dim objFolder As Object
Dim X As Object
Dim Y As Object

lRowCounter = 0
Ordnercount = 0

Range("D4") = ""
Range("D5") = ""

If Range("D8") <> "Alle" Then
Range("D9").Font.Color = RGB(63, 63, 118)
End If

If Range("A1") <> "" Then
Call del_b
End If

  Set objShell = CreateObject("Shell.Application")
  With objShell
  If Range("D11") = "" Then
 
'    MkDir (ThisWorkbook.Path & "\Wartungen\" & Range("H12").Value)
 
    Set objFolder = .BrowseForFolder(0&, "Pfad", 0, "" & ThisWorkbook.Path & "\Wartungen\" & "")
    Else
    Set objFolder = .BrowseForFolder(0&, "Pfad", 0, "" & ThisWorkbook.Path & "\Wartungen\" & Range("D11") & "\")
    End If
  End With

Set X = CreateObject("Scripting.FileSystemObject")

If (Not objFolder Is Nothing) Then
Set Y = X.GetFolder(objFolder.self.Path)

Else
  Exit Sub
  End If
'Set y = x.GetFolder(ActiveWorkbook.Path)


[a1] = "HAUPTORDNER: " & Y.Path
[a1].Interior.Color = vbBlue
[a1].Font.Color = RGB(255, 255, 255)
Dateien Y.Files
Ordner Y


If Range("D9").Value <> "" Then

If lRowCounter = 0 Then
Range("D5") = "Es wurden keine Dateien gefunden!"
ElseIf lRowCounter = 1 Then
Range("D5") = "Es wurde " & lRowCounter & " Dateie gefunden!"
Else
Range("D5") = "Es wurden " & lRowCounter & " Dateien gefunden!"
End If


If lRowCounter = 0 Then

If Range("D7").Value <> "" Then

MsgBox "Es wurden keine Dateien mit " & """" & Range("D7") & """" & " im Dateinamen gefunden!"

Else

MsgBox "Es wurden keine Dateien mit der Endung " & """" & Range("D9") & """" & " gefunden!"

End If

ElseIf lRowCounter = 1 Then

If Range("D7").Value <> "" Then

MsgBox "Es wurde " & lRowCounter & " Datei mit " & """" & Range("D7") & """" & " im Dateinamen gefunden!"

Else

MsgBox "Es wurde " & lRowCounter & " Datei mit der Endung " & """" & Range("D9") & """" & " gefunden!"

End If
Else

If Range("D7").Value <> "" Then

MsgBox "Es wurden " & lRowCounter & " Dateien mit " & """" & Range("D7") & """" & " im Dateinamen gefunden!"

Else

MsgBox "Es wurden " & lRowCounter & " Dateien mit der Endung " & """" & Range("D9") & """" & " gefunden!"

End If
End If


Else

Range("D5") = lRowCounter

If lRowCounter = 0 Then

If Range("D8") = "Alle" Then
MsgBox "Es wurden keine Dateien gefunden!"
Else
If Range("D9") = "" Then
MsgBox "Es wurden keine Dateien gefunden!"
Else
MsgBox "Es wurden keine Dateien mit der Endung " & """" & Range("D9") & """" & " gefunden!"
End If

End If

ElseIf lRowCounter = 1 Then
MsgBox "Es wurde " & lRowCounter & " Datei gefunden!"
Else
MsgBox "Es wurden " & lRowCounter & " Dateien gefunden!"
End If

End If

If Ordnercount > 0 Then
Range("D4") = "Es wurden " & Ordnercount & " Ordner gefunden!"
End If

'------------------
' Unterordner auslesen und in Spalte I auflisten
On Error Resume Next

If Range("I2") <> "" Then
Call del_b
End If

Dim lRow As Long

Dim oFolder As Object, oSFolder As Object, oFS As Object
Set oFS = CreateObject("Scripting.filesystemobject")
Set oFolder = oFS.GetFolder(ThisWorkbook.Path & "\Wartungen\")
For Each oSFolder In oFolder.SubFolders
ActiveSheet.Cells(Rows.Count, 9).End(xlUp).Offset(1) = oSFolder.Name

Next

lRow = ActiveSheet.Cells(Rows.Count, 9).End(xlUp).Row
ActiveWorkbook.Names.Add Name:="Ordnername", RefersToR1C1:="=Dateiablage!R2C9:R" & lRow & "C9"

'Sheets("Ordner").Visible = False
ActiveSheet.Range("D11").Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=Ordnername"
'------------------
   

Range("A1").Select

End Sub

Sub Dateien(Objekt As Object)

Dim Item As Object

For Each Item In Objekt

If Range("D7").Value <> "" Then
'Range("D8") = ""

If Range("D8") = "Alle" Then
Range("D9") = "*"
Range("D9").Font.Color = RGB(250, 191, 143)
End If

End If


If Range("D7") <> "" And Range("D9") <> "" Then

' UCase(Range("D8")) bedeutet Umwandlung der endung auf Großbuchstaben
If InStrRev(Range("D7") & Range("D9"), Range("D9")) > 0 Or InStrRev(Range("D7") & Range("D9"), UCase(Range("D9"))) > 0 Then

'If Item.Name = Range("D7") & Range("D9") Or Item.Name = Range("D7") & UCase(Range("D9")) Then
 
If Item.Name Like "*" & Range("D7") & "*" & Range("D9") Or UCase(Item.Name) Like "*" & UCase(Range("D7")) & "*" & UCase(Range("D9")) Then

   
    [a65536].End(xlUp).Offset(1, 0) = "=HYPERLINK(" & _
                    """" & Item.Path & """," & _
                    """" & Item.Name & """)"
                   
                    lRowCounter = lRowCounter + 1
                   
                    End If
                   
                    End If
                   
Else


If InStrRev(Item.Name, Range("D9")) > 0 Or InStrRev(Item.Name, UCase(Range("D9"))) > 0 Then
   
    [a65536].End(xlUp).Offset(1, 0) = "=HYPERLINK(" & _
                    """" & Item.Path & """," & _
                    """" & Item.Name & """)"
                   
                    lRowCounter = lRowCounter + 1
                   
End If

End If
                   
Next

End Sub

Sub Ordner(Objekt As Object)

Dim Ordnername$, Ordnername2$
Dim Item As Object

Dim lRow As Long

For Each Item In Objekt.SubFolders

'Original
'[a65536].End(xlUp).Offset(1, 0) = "Ordner: -> " & Item.Name
   
'Hyperlink zum Ordner
'[a65536].End(xlUp).Offset(1, 0) = "=HYPERLINK(" & """" & Item.Path & "\"",""Ordner: -> "" & " & """" & Item.Name & """)"


[a65536].End(xlUp).Offset(1, 0) = "=HYPERLINK(" & """" & Item.Path & "\""," & """" & Item.Name & """)"
   
   
    [a65536].End(xlUp).Font.Color = RGB(0, 0, 0)
    [a65536].End(xlUp).Font.Bold = True
'    [a65536].End(xlUp).Interior.Color = RGB(50, 250, 0)
    Dateien Item.Files
      Ordner Item
   
    Ordnercount = Ordnercount + 1

Next

End Sub


Sub del_a()

    Columns("A:A").Select
    Selection.ClearContents
    Selection.ClearFormats
    With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Range("D4") = ""
    Range("D5") = ""
    Range("D7") = ""
    Range("D8") = ""
    Range("D9") = ""
    Range("D11") = ""
    Range("A1").Select
   
        '-------------
ActiveSheet.Columns("I:I").Select
    Selection.ClearContents
    Selection.ClearFormats
    With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    ActiveSheet.Range("I2").Select
    ActiveSheet.Range("I1") = "Ordnerliste"
    ActiveSheet.Range("I1").Font.Bold = True
    '---------------

Range("A1").Select

End Sub

Sub del_b()

    Columns("A:A").Select
    Selection.ClearContents
    Selection.ClearFormats
    With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Range("A1").Select
   
    '-------------
ActiveSheet.Columns("I:I").Select
    Selection.ClearContents
    Selection.ClearFormats
    With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    ActiveSheet.Range("I2").Select
    ActiveSheet.Range("I1") = "Ordnerliste"
    ActiveSheet.Range("I1").Font.Bold = True
    '---------------

Range("A1").Select

End Sub

Danke für Eure Hilfe!

[snb]

Code:

Sub M_snb()
  sn=Split(CreateObject("wscript.shell").Exec("cmd /c dir G:\*.* /b /a-d /s").StdOut.ReadAll, vbCrLf)
  redim sp(ubound(sn),0)

  for j=0 to ubound(sn)
    sp(j,0)=sn(j)
  next
  cells(1).resize(ubound(sn)+1)=sp
End Sub

[Andyle]

Da meine vba-Kenntnisse nicht wirklich gut sind, sagt mir der Code leider nichts.

[snb]

Der Code spricht auch nicht.
Nur testen reicht.

[Andyle]

rufe ich den code auf, kommt erstmal eine Fehlermeldung Variable nicht definiert (sn)

UBound erwartet Datenfeld!

[knobbi38]

Hallo,

anstatt hier soviel Code zu veröffentlichen wäre ein Beispiel nicht schlecht gewesen, damit man auch verstehen kann, was du eigentlich möchtest, denn wenn du mit File-Objekten arbeitest, hast du doch alle Informationen zu jeder Datei, de du brauchst.

Die Lösung von snb arbeitet nur ohne "Option Explicit" und sollte man nur anwenden, wenn man auch versteht, wie das funktioniert. Auch kann es durch den Aufruf von Dir() auf der Kommandozeile zu Problemen mit dem Zeichensatz kommen.

Gruß
Knobbi38

[oee]

" "Option Explicit" ... sollte man nur anwenden, wenn man auch versteht, wie das funktioniert. " ? Das ist doch Quatsch !
Gerade als Anfänger sollte man nur mit "Option Explicit"  arbeiten, damit man merkt, wenn Variablen nicht deklariert sind bzw falsch geschrieben wurden.

[RPP63]

Knobbi38 hat das genau so geschrieben, wie Du meinst oee.

Die Lösung von snb arbeitet nur ohne "Option Explicit" und sollte man nur anwenden, wenn man auch versteht, wie das funktioniert.

Ich finde auch, dass der Endloscode von Andyle fast eine Zumutung ist.
Statt z.B.

Code:

    Range("D4") = ""
    Range("D5") = ""
    Range("D7") = ""
    Range("D8") = ""
    Range("D9") = ""
    Range("D11") = ""

würde ich ja folgendes nehmen

Code:

Range("D4:D9,D11").ClearContents

Und das ist nur eines von vielen Beispielen …

Gruß Ralf

[Andyle]

Vieleicht noch mal zum leichteren Verständnis


Ich habe einen Hauptordner(Wartungen)

Darin liegen Unterordner mit Unterordner

Ich möchte einfach der Übersicht wegen folgendes:

ist es ein Ordner unter Ebene (Wartungen) soll

>>>Ordnername1

stehen.

Hat Ordnername1 einen Unterordner soll

>>Unterordner1

stehen.    Also nur >>> bzw. >> vor die jeweiligen Ordner setzen.

[snb]

Schon getestet ohne 'option explicit' ?