Dateipfade auslesen

Sub Dateien_aus_Ordner_auflisten() Dim Dateiname As String Dim i As Integer Range("B1:B2000").ClearContents Range("B1").Select Dateiname = Dir$("U:\Mal\AKTUELL-DRUCK\0001-0999\*.pdf") Do While Dateiname "" ActiveCell.Offset(i, 0) = Dateiname i = i + 1 Dateiname = Dir$() Loop Dateiname = Dir$("U:\Mal\AKTUELL-DRUCK\1000-9999\*.pdf") Do While Dateiname "" ActiveCell.Offset(i, 0) = Dateiname i = i + 1 Dateiname = Dir$() Loop Dateiname = Dir$("U:\Mal\AKTUELL-DRUCK\E-MAL\*.pdf") Do While Dateiname "" ActiveCell.Offset(i, 0) = Dateiname i = i + 1 Dateiname = Dir$() Loop Dateiname = Dir$("U:\Mal\AKTUELL-DRUCK\L-MAL\*.pdf") Do While Dateiname "" ActiveCell.Offset(i, 0) = Dateiname i = i + 1 Dateiname = Dir$() Loop Dateiname = Dir$("U:\Mal\AKTUELL-DRUCK\M-MAL\*.pdf") Do While Dateiname "" ActiveCell.Offset(i, 0) = Dateiname i = i + 1 Dateiname = Dir$() Loop Dateiname = Dir$("U:\Mal\AKTUELL-DRUCK\N-MAL\*.pdf") Do While Dateiname "" ActiveCell.Offset(i, 0) = Dateiname i = i + 1 Dateiname = Dir$() Loop Dateiname = Dir$("U:\Mal\AKTUELL-DRUCK\T-TE-MAL\*.pdf") Do While Dateiname "" ActiveCell.Offset(i, 0) = Dateiname i = i + 1 Dateiname = Dir$() Loop End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hi Markus,
probier mal, wie schnell das mit diesem Code geht:


Option Explicit
' Dateien auflilsten auch in Unterordnern
' Josef Ehrensberger  am 16.01.2009 12:19:13
' www.herber.de/forum/archiv/1040to1044/t1040526.htm#1040532
' modifiziert Erich G. 17.01.2009, 10.02.2009
Sub ListeFiles()
Dim arrV, intVz As Integer, lngZ As Long
Dim result As Long, lngF As Long, arrF() As Object, arrE()
arrV = Split("U:\Mal\AKTUELL-DRUCK\0001-0999\" & _
";U:\Mal\AKTUELL-DRUCK\1000-9999\" & _
";U:\Mal\AKTUELL-DRUCK\E-MAL\" & _
";U:\Mal\AKTUELL-DRUCK\L-MAL\" & _
";U:\Mal\AKTUELL-DRUCK\M-MAL\" & _
";U:\Mal\AKTUELL-DRUCK\N-MAL\" & _
";U:\Mal\AKTUELL-DRUCK\T-TE-MAL\", ";")
Cells(1, 1) = "Dateiname"
lngZ = 2
For intVz = 0 To UBound(arrV)
FileSearchINF result, arrF, arrV(intVz), "*.pdf", False
If result > 0 Then
ReDim arrE(1 To result)
For lngF = 1 To result
arrE(lngF) = arrF(lngF - 1).Path
Next
Cells(lngZ, 1).Resize(result) = Application.Transpose(arrE)
lngZ = lngZ + result
End If
result = 0
Next intVz
End Sub
Private Sub FileSearchINF(ByRef lngA As Long, _
ByRef varA() As Object, _
ByVal strPath As String, _
Optional ByVal strNam As String = "*", _
Optional ByVal bolSubF As Boolean = False)        'by J.Ehrensberger
' PARAMETER:
'  lngA:    Anzahl Suchergebnisse
'  varA:    Datenfeld für Suchergebnis.  UBound(varA) kann > lngA sein!
'  strPath: zu durchsuchendes Verzeichnis
'  strNam:  gesuchter Dateityp oder -name (Optional, Standard="*.*" findet alle Dateien)
'           Bsp: "*.txt"         alle Textdateien
'                "*name*"        alle Dateien mit "name" im Dateinamen
'                "*.avi;*.mpg"   .avi- und .mpg-Dateien (Dateitypen mit ; trennen)
'  bolSubF: ob Unterordner durchsucht werden sollen (Optional, Standard=False)
Dim objFSO As Object, fsoFold As Object, fsoSubFo As Object, fsoFile As Object
Dim intC As Integer, varTyp As Variant, dummy As Long
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set fsoFold = objFSO.GetFolder(strPath)
If InStr(1, strNam, ";") > 0 Then
varTyp = Split(strNam, ";")
Else
ReDim varTyp(0)
varTyp(0) = strNam
End If
On Error Resume Next                     ' evtl. bei geschützten Verz.
dummy = fsoFold.Files.Count
On Error GoTo 0
If dummy > 0 Then
For Each fsoFile In fsoFold.Files
If Not fsoFile Is Nothing Then
For intC = 0 To UBound(varTyp)
If LCase(objFSO.GetFileName(fsoFile)) Like LCase(varTyp(intC)) Then
If lngA = 0 Then
ReDim varA(1000)
ElseIf lngA > UBound(varA) Then
ReDim Preserve varA(UBound(varA) + 500)
End If
Set varA(lngA) = fsoFile
lngA = lngA + 1
Exit For
End If
Next
End If
Next
End If
If bolSubF Then
On Error Resume Next                     ' evtl. bei geschützten Verz.
dummy = fsoFold.SubFolders.Count
On Error GoTo 0
If dummy > 0 Then
For Each fsoSubFo In fsoFold.SubFolders
FileSearchINF lngA, varA, fsoSubFo, strNam, True
Next
End If
End If
Set objFSO = Nothing
Set fsoFold = Nothing
End Sub

Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort

Sub Dateien_aus_Ordner_auflisten() Dim Dateiname As String Dim i As Integer, vntDateinamen() Application.ScreenUpdating = False Range("B:B").ClearContents Range("B1").Select ReDim vntDateinamen(1 To 1, 1 To 1) Dateiname = Dir$("U:\Mal\AKTUELL-DRUCK\0001-0999\*.pdf") Do While Dateiname "" i = i + 1 ReDim Preserve vntDateinamen(1 To 1, 1 To i) vntDateinamen(1, i) = Dateiname Dateiname = Dir$() Loop Dateiname = Dir$("U:\Mal\AKTUELL-DRUCK\1000-9999\*.pdf") Do While Dateiname "" i = i + 1 ReDim Preserve vntDateinamen(1 To 1, 1 To i) vntDateinamen(1, i) = Dateiname Dateiname = Dir$() Loop Dateiname = Dir$("U:\Mal\AKTUELL-DRUCK\E-MAL\*.pdf") Do While Dateiname "" i = i + 1 ReDim Preserve vntDateinamen(1 To 1, 1 To i) vntDateinamen(1, i) = Dateiname Dateiname = Dir$() Loop Dateiname = Dir$("U:\Mal\AKTUELL-DRUCK\L-MAL\*.pdf") Do While Dateiname "" i = i + 1 ReDim Preserve vntDateinamen(1 To 1, 1 To i) vntDateinamen(1, i) = Dateiname Dateiname = Dir$() Loop Dateiname = Dir$("U:\Mal\AKTUELL-DRUCK\M-MAL\*.pdf") Do While Dateiname "" i = i + 1 ReDim Preserve vntDateinamen(1 To 1, 1 To i) vntDateinamen(1, i) = Dateiname Dateiname = Dir$() Loop Dateiname = Dir$("U:\Mal\AKTUELL-DRUCK\N-MAL\*.pdf") Do While Dateiname "" i = i + 1 ReDim Preserve vntDateinamen(1 To 1, 1 To i) vntDateinamen(1, i) = Dateiname Dateiname = Dir$() Loop Dateiname = Dir$("U:\Mal\AKTUELL-DRUCK\T-TE-MAL\*.pdf") Do While Dateiname "" i = i + 1 ReDim Preserve vntDateinamen(1 To 1, 1 To i) vntDateinamen(1, i) = Dateiname Dateiname = Dir$() Loop Range("B1").Resize(i) = WorksheetFunction.Transpose(vntDateinamen) Application.ScreenUpdating = True End Sub

Beliebteste Forumthreads (12 Monate)

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread