VBA 2 einfache "?" Fragen

Public Function Pfad_Datei(Blatt$) As String Dim Pfad As String Dim Datei As String With Worksheets(Blatt$) 'Hole aus Zelle B1 den Pfad Pfad = .Range("B1").Value 'Hole aus Zelle B2 den Dateinamen Datei = .Range("B2").Value End With 'Überprüfe, ob Pfad am Ende einen "\" hat; falls nicht füge ihn an If Right(Pfad, 1) "\" Then Pfad = Pfad & "\" 'Gib beides Pfad+Dateiname als Rückgabewert aus der Funktion zurück Pfad_Datei = Pfad & Datei End Function

Option Explicit Dim FSO, FO, FU, f Dim lRow As Long Dim icol As Integer Public Sub Ordner_inMF() Set FSO = CreateObject("Scripting.FileSystemObject") icol = 1 lRow = 0 GetSubFolders "G:\Ralf\++++ in MF" End Sub Function GetSubFolders(Pfad) Set FO = FSO.GetFolder(Pfad) Set FU = FO.SubFolders On Error Resume Next For Each f In FU lRow = lRow + 1 Cells(lRow, icol) = f.Name Next icol = icol - 1 End Function

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Public Function Pfad_Datei(ZellePfad As Variant, ZelleDatei As Variant) As String Dim Pfad As String Dim Datei As String 'Hole aus Zelle den Pfad Pfad = ZellePfad 'Hole aus Zelle den Dateinamen Datei = ZelleDatei 'Überprüfe, ob Pfad am Ende einen "\" hat; falls nicht füge ihn an If Right(Pfad, 1) "\" Then Pfad = Pfad & "\" 'Gib beides Pfad+Dateiname als Rückgabewert aus der Funktion zurück Pfad_Datei = Pfad & Datei End Function

Option Explicit Dim FSO, FO, FU, f Dim lRow As Long Dim icol As Integer Sub Ordner_Listen1() 'Makro für Schaltfläche Dim Zelle As Range With Worksheets("Tabelle1") .Activate lRow = 7 'Startzeile für Ordnernamen For Each Zelle In .Range("C2:C6").Cells 'Zellbereich mit Ordnername(n) If Zelle "" Then Call Ordner_inMF(strFolder:=Zelle.Text, bolSubFolders:=True) End If Next End With End Sub Public Sub Ordner_inMF(strFolder As String, ByVal bolSubFolders As Boolean) 'Unterverzeichnisse im Ordner Listen Set FSO = CreateObject("Scripting.FileSystemObject") icol = 0 GetSubFolders strFolder, bolSubFolders:=bolSubFolders Set FSO = Nothing End Sub Function GetSubFolders(Pfad, Optional ByVal bolSubFolders As Boolean) 'Unterverzeichnisse + optional Unter-Unter-Verzeichnisse im Ordner Listen - Set FO = FSO.GetFolder(Pfad) Set FU = FO.SubFolders icol = icol + 1 'Spalte für nächste Stufe Unterverzeichnis erhöhen On Error Resume Next For Each f In FU lRow = lRow + 1 Cells(lRow, icol) = f.Name If bolSubFolders = True Then GetSubFolders (f) Next icol = icol - 1 'Spalte für vorherige Stufe Unterverzeichnis erniedrigen End Function

Hallo Franz,
ich sage schonmal Danke.
So richtig schlau werde ich noch nicht...
zu 1. mit den Pfaden
Ich habe nun folgende Pfade in den Zellen in der Tabelle "Parameter"
B1 = Pfad "G:\Ralf" (Hauptpfad)
B2 = "angenommen" (Unterordner1)
B3 = "abgelehnt" (Unterordner2)
B4 = "in Schwebe" (Unterordner3)
Für jeden der 4 Ordner habe ich ein Tabellenblatt angelegt, in das die enthaltenen Ordner hereinkopiert werden sollen. Dazu habe ich den umständlichen Weg gewählt, pro Tabellenblatt den obigen Code mit GetSubFolders "G:\Ralf\++++ in MF (jeweils mit dem eigenen Pfad) anzulegen.
Das geht auch gut. Allerdings möchte ich halt den Pfad durch die Eingaben in den Zellen B1 bis B4 nachträglich abändern können. Hier fehlt mir nun ein wenig das Verständnis....
Kannst Du mir evtl. einen pragmatischen Tipp geben wie ich es schaffe, die Pfade im Makro "variabel" zu gestalten?

Hallo Ralf,
wenn du es variabel haben möchtest, dann musst du statt der festen Texte im Code entsprechende Verweise auf die Zellen im Blatt "Parameter" einbauen.
Nachfolgend hab ich mal das Makro OrdnerListen so angepasst, dass es alle Unterordner in einer Schleife abarbeitet. Die anderen Makros sind unverändert. Dabei ist die Anzahl der Unterordner beliebig. Es müssen nur entsprechend viele Tabellenblätter für die Ordnerlisten vorhanden sein.
Gruß
Franz

Option Explicit
Dim FSO, FO, FU, f
Dim lRow As Long
Dim icol As Integer
Sub Ordner_Listen() 'Makro für Schaltfläche
Dim Zelle As Range, wksParam As Worksheet, wksOrdner As Worksheet
Dim ZeileUO As Long, Zeile_L As Long, intBlatt As Integer
On Error GoTo Fehler
Set wksParam = Worksheets("Parameter") 'Tabellenblatt mit Hauptordner in B1, und _
Unterordnern in B2 bis Bx                - #### Blattname ggf. anpassen ####
'Prüfen, ob Unterordner eingegeben sind
If wksParam.Range("B2").End(xlDown).Row = wksParam.Rows.Count Then
MsgBox "Es sind keine Unterordner eingegeben!"
Exit Sub
End If
intBlatt = 2 'Indexnummer des 1. Tabellenblatts in das eine Ordnernummer _
eingetragen werden soll   - #### ggf. anpassen ####
Application.ScreenUpdating = False
For ZeileUO = 2 To wksParam.Range("B1").End(xlDown).Row 'in Zeile 2 bis zur letzten _
in Spalte B stehen Namen der Unterordner
Set Zelle = wksParam.Cells(ZeileUO, 2) 'Zelle mit Unterordner
If Zelle  "" Then
'Tabellenblatt für die Ordnerliste festlegen
Set wksOrdner = Worksheets(intBlatt)
With wksOrdner
.Activate
lRow = 3   'Startzeile für Ordnernamen   - #### ggf. anpassen ####
'Altdaten löschen
Zeile_L = .UsedRange.Row + .UsedRange.Rows.Count - 1 'letzte Zeile mit Daten
If Zeile_L >= lRow Then
.Range(.Rows(lRow), .Rows(Zeile_L)).ClearContents
End If
'Ordnerliste erstellen
Call Ordner_inMF(strFolder:=Pfad_Datei(wksParam.Range("B1").Text, Zelle.Text), _
bolSubFolders:=True)
End With
intBlatt = intBlatt + 1 'Indexnummer für Blatt für nächste Ordnerliste erhöhen
End If
Next
MsgBox "Ordnerlisten erstellt!"
Fehler:
With Err
Select Case .Number
Case 0 'alles OK
Case 9
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description & vbLf & vbLf _
& "Es sind mehr Unterordner in der Liste vorhanden als " _
& "Tabellenblätter für die Ordnerlisten"
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End Select
End With
wksParam.Activate
Application.ScreenUpdating = True
End Sub
Public Sub Ordner_inMF(strFolder As String, ByVal bolSubFolders As Boolean)
'Unterverzeichnisse im Ordner Listen
Set FSO = CreateObject("Scripting.FileSystemObject")
icol = 0
GetSubFolders strFolder, bolSubFolders:=bolSubFolders
Set FSO = Nothing
End Sub
Function GetSubFolders(Pfad, Optional ByVal bolSubFolders As Boolean)
'Unterverzeichnisse + optional Unter-Unter-Verzeichnisse im Ordner Listen -
Set FO = FSO.GetFolder(Pfad)
Set FU = FO.SubFolders
icol = icol + 1 'Spalte für nächste Stufe Unterverzeichnis erhöhen
On Error Resume Next
For Each f In FU
lRow = lRow + 1
Cells(lRow, icol) = f.Name
If bolSubFolders = True Then GetSubFolders (f)
Next
icol = icol - 1 'Spalte für vorherige Stufe Unterverzeichnis erniedrigen
End Function
Public Function Pfad_Datei(ZellePfad As Variant, ZelleDatei As Variant) As String
Dim Pfad As String
Dim Datei As String
'Hole aus Zelle den Pfad
Pfad = ZellePfad
'Hole aus Zelle den Dateinamen
Datei = ZelleDatei
'Überprüfe, ob Pfad am Ende einen "\" hat; falls nicht füge ihn an
If Right(Pfad, 1)  "\" Then Pfad = Pfad & "\"
'Gib beides Pfad+Dateiname als Rückgabewert aus der Funktion zurück
Pfad_Datei = Pfad & Datei
End Function

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

VBA 2 einfache "?" Fragen

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

300 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread