Ordnernamen Excel Liste

[Bboy.Endless]

Hallo Community,

Ich bräuchte mal Hilfe von euch

Ich hab in einem Ordner mehrere Unterordner von Fotos, und möchte diese mithilfe eines Makros als namen in Excel stehen haben..

Ich habe auch schon ein Makro, nur schreibt er mir hierbei den kompletten Pfad als Namen hin.. leider bin ich nicht so mächtig mit dem entwerfen, und hoffe einer von euch kann mir da weiter helfen.

Leider muss ich auch hier, wenn ein neuer Ordner hinzu kommt immer wieder das Makro neu ausführen, und sachen die in den Spalten dahinter stehen verschieben sich dann natürlich nicht mit..

Vielen dank schon mal



Option Explicit

Dim z
Public Sub Aufruf()
Dim objShell As Object
Dim objFolder As Object
Dim objItem As Object
Set objShell = CreateObject("Shell.Application")
With objShell
Set objFolder = .BrowseForFolder(0&, "Was soll ich machen?", 0, "D:\Eigene Dateien")
End With
If Not objFolder Is Nothing Then
Set objItem = objFolder.Self
Else: Exit Sub
End If
z = 1
Schreiben objItem.Path, True 'true wenn die Unterordner auch wieder geschrieben werden sollen
'Sonst false oder weglassen
End Sub

Public Sub Schreiben(V, Optional sbfolds As Boolean = False)
Dim fso As Object
Dim datei
Dim Unterordner
Set fso = CreateObject("Scripting.FileSystemObject")
Set datei = fso.GetFolder(V)
Select Case sbfolds
Case True
For Each Unterordner In datei.Subfolders
Cells(z, 1) = Unterordner.Path
z = z + 1
Schreiben Unterordner, True
Next
Case False
For Each Unterordner In datei.Subfolders
Cells(z, 1) = Unterordner.Path
z = z + 1
Next
End Select
Set fso = Nothing
Set datei = Nothing
End Sub

 

[schumischumi]

Wenns nur die Unterordner sein sollen hilft die Lösung vonhttp://www.ms-office-forum.net/forum/showthread.php?t=325201

Sub ListeAbrufen()
  Dim objFSO As Object
  Dim objFolder As Object
  Dim strPfad As String
  Dim objSubfolder As Object, colSubfolders As Object
  Dim rng As Excel.Range
  Dim lngZeile As Long
  Dim lngZeileStart As Long
  
  i = 1
  strPfad = "C:\" 'Der auszulesende Ordner
  Set objFSO = CreateObject("Scripting.FileSystemObject")
  Set objFolder = objFSO.GetFolder(strPfad)
  Set colSubfolders = objFolder.Subfolders
  'erste Zeile finden, in die etwas eingetragen werden darf
  lngZeile = IIf(IsEmpty(Cells(1, 1)), 1, Cells(Rows.Count, 1).End(xlUp).Row + 1)
  lngZeileStart = lngZeile
  
  Application.ScreenUpdating = False
  
  'Für alle Unterordner
  For Each objSubfolder In colSubfolders
    'In Spalte A suchen, ob es den Eintrag schon gibt
    Set rng = Range("A:A").Find(What:=objSubfolder.Name)
    If rng Is Nothing Then 'Wenn kein Eintrag gefunden wurde
      '..dann am Ende der Liste eintragen
      Cells(lngZeile, 1).Value = objSubfolder.Name
      'Cells(lngZeile, 3).Value = "Offen"
      'Cells(lngZeile, 5).Value = objSubfolder.DateCreated
      'nächste freie Zeile
      lngZeile = lngZeile + 1
    End If
  Next
  
  If lngZeile <> lngZeileStart Then  'Wenn es etwas zu sortieren gibt
    '...dann nach der Spalte A sortieren
    With ActiveSheet.Sort
      .SortFields.Clear
      .SortFields.Add Key:=Range("A:A"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
      .SetRange Range("1:" & lngZeile)
      .Header = xlGuess
      .MatchCase = False
      .Orientation = xlTopToBottom
      .SortMethod = xlPinYin
      .Apply
    End With
  End If
  
  Application.ScreenUpdating = True
  
  Set objFolder = Nothing
  Set colSubfolders = Nothing
  Set objFSO = Nothing
End Sub

 

[Bboy.Endless]

Zitat entfernt - Bitte Regeln beachten!​

Vielen dank für deine Antwort.
das is schon sehr nahe dran, bzw eigentlich genauso, die weiteren Spalten ziehen sich wie gewollt mit.

aber das das Makro dann jedesmal ausgeführt werden muss, ist nicht zu verhindern oder?

ich meine ist ja nicht schlimm.
aber interessieren würde es mich, ob die abfrage auch automatisch gehen könnte, z.b beim neu öffnen oder so

 

[pumuck|]

Ich hab "dein" Makro nicht getestet, aber theoretisch müsste es mit folgenden Anpassungen gehen:

Option Explicit

Dim z
Public Sub Aufruf()
Dim objShell As Object
Dim objFolder As Object
Dim objItem As Object
Set objShell = CreateObject("Shell.Application")
With objShell
Set objFolder = .BrowseForFolder(0&, "Was soll ich machen?", 0, "D:\Eigene Dateien")
End With
If Not objFolder Is Nothing Then
Set objItem = objFolder.Self
Else: Exit Sub
End If
z = 1
End Sub

Public Sub Schreiben(V, Optional sbfolds As Boolean = False)
Dim fso As Object
Dim datei
Dim Unterordner
Set fso = CreateObject("Scripting.FileSystemObject")
Set datei = fso.GetFolder(V)
Select Case sbfolds
Case True
For Each Unterordner In datei.Subfolders
Cells(z, 1) = Unterordner.Path
z = z + 1
Schreiben Unterordner, False
Next
Case False
For Each Unterordner In datei.Subfolders
Cells(z, 1) = Unterordner.Path
z = z + 1
Next
End Select
Set fso = Nothing
Set datei = Nothing
End Sub

Hm was mich stutzig macht Case False und True sind identisch?

 

[cumulonimbus8]

aber das das Makro dann jedesmal ausgeführt werden muss, ist nicht zu verhindern oder?

Wie sonst sollte diese Aufstellung jedweder Änderungen ›außerhalb‹ gewahr werden?
Der Neuaufruf ist sicherlich handlicher beim Programmieren als nachzuforschen was auf dem Blatt existiert und dann evtl. korrigiert werden müsste.

CN8


@pumuck|
Wie soll deine Sub Schreiben aufgerufen werden, wozu Aufrufparameter (die mal allgemein nur bei Functions nutzt), warum sind die Variablen nicht sauber deklariert, und eine Zelle die mit Zeile 0 (Zustand von Variable Z) aufgerufen wird sollte crashen…