Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
592to596
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
592to596
592to596
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Dateien und Ordner auslesen
08.04.2005 08:09:18
Martin
Hallo und guten Morgen!
Ich habe in der Recherche einiges zum Thema Dateien auslesen gefundn, allerdings nicht das, was ich jetzt benötige. Kann mir jemand helfen?
Ich möchte gerne ein komplettes Laufwerk (Beispielsweise C: oder N: durchsuchen und im Prinzip eine Ordnungsstruktur mit allesn Ordnern, Unterordnern und Dateien (Word, Excel, PDF, Powerpoint) mit Namen und Größe [und am besten auch Datum der letzten Änderung(nicht so wichtig!)] aufzeigen lassen. Diese will ich anschließend ausdrucken.
Vielen Dank
Martin

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

Betreff
Datum
Anwender
Anzeige
AW: Dateien und Ordner auslesen
08.04.2005 08:54:37
Martin
Hallo OttoH,
vielen Dank für den Vorschlag, habe ihn auch sofort ausprobiert, allerdings reicht mir das nicht. Ich bekomme gleich die Meldung, daß er nur 100 Ordner und 1000 Dateien berücksichtigt. Damit komm ich nicht hin. Habe bei weiterem mehr von beiden. Hast Du vielleicht sonst noch eine Idee?
Danke,
Martin
AW: Dateien und Ordner auslesen
08.04.2005 08:58:11
ottoh
Hallo Martin,
mehr fällt mir auch nicht ein. Ich lese immer nur einen bestimmte Ordner ein. Den Dateilister aus Add-In-World habe ich auch noch nicht soweit getrieben, dass er an seine Grenzen gestoßen ist.
Gruß OttoH
Anzeige
AW: Dateien und Ordner auslesen
08.04.2005 09:42:21
Rolf
Hallo Martin,
hier eine nicht besonders komfortable Variante -
schau mal, ob sie dir trotzdem reicht.
Läuft bei mir ca. 4 Min. bei 24.000 Dateien.
fG
Rolf
Option Explicit

Sub dateien_ausgeben()
'Rolf Beißner
Dim fs As Object
Dim fso As Object
Dim i As Integer, n As Integer
Dim A As Variant
A = Array("Pfad", "Datei", "LastModify")
ActiveWorkbook.Sheets.Add
With Range("A1:C1")
.Value = A
.Interior.ColorIndex = 15
.Font.Bold = True
End With
Application.ScreenUpdating = False
Set fs = CreateObject("Scripting.FileSystemObject")
Set fso = Application.FileSearch
With fso
.NewSearch
.LookIn = "C:\"             'Laufwerk ggfs. ändern
.Filename = "*.*"
.SearchSubFolders = True
If .Execute() > 0 Then
n = .FoundFiles.Count
MsgBox n & " Datei(en) gefunden"
For i = 1 To n
Cells(i + 1, 1) = fs.GetParentFolderName(.FoundFiles(i))
Cells(i + 1, 2) = fs.GetFileName(.FoundFiles(i))
Cells(i + 1, 3) = fs.GetFile(.FoundFiles(i)).DateLastModified
Next i
End If
End With
Columns.AutoFit
Application.ScreenUpdating = True
End Sub

Anzeige
AW: Dateien und Ordner auslesen
08.04.2005 10:36:58
Martin
Hallo Rolf,
hat leider nicht so ganz geklappt. Da hat sich Excel bei mir aufgehängt. Trotzdem Danke!!
Habe aber dann doch noch was gefunden was mir hilft:
Public Sub Searching_files()
Dim myFileSystemObject As New FileSystemObject, myFile As File, myFileSearch As FileSearch
Dim strName() As String, strPath() As String, strPath_old As String
Dim lngIndex As Long, lngRow As Long, lngCount As Long, lngFolder As Long, lngStart As Long
Dim intColumn As Integer
Cells.Clear
Application.ScreenUpdating = False
Set myFileSearch = Application.FileSearch
With myFileSearch
.LookIn = strDrive
.FileType = msoFileTypeAllFiles
.SearchSubFolders = True
.Execute
On Error Resume Next
For lngIndex = 1 To .FoundFiles.Count
Set myFile = myFileSystemObject.GetFile(.FoundFiles(lngIndex))
If Err.Number = 0 Then
If Left$(myFile.ParentFolder, 1) = Left$(strDrive, 1) Then
lngCount = lngCount + 1
ReDim Preserve strName(1 To lngCount)
ReDim Preserve strPath(1 To lngCount)
strName(lngCount) = myFile.Name
strPath(lngCount) = myFile.ParentFolder
End If
End If
Err.Clear
Next
On Error GoTo 0
End With
Set myFile = Nothing
Set myFileSearch = Nothing
Call Arrange(1, lngCount, strName, strPath)
lngRow = 1
intColumn = 1
Call Heading(1)
For lngIndex = 1 To lngCount
If strPath_old strPath(lngIndex) Then
If lngRow > 1 Then Range(Cells(lngStart, intColumn), Cells(lngRow, intColumn)).Sort Key1:=Cells(lngStart, intColumn)
Call Row_control(lngRow, intColumn, 3)
With Cells(lngRow, intColumn)
.Value = strPath(lngIndex)
.Font.Bold = True
End With
lngFolder = lngFolder + 1
strPath_old = strPath(lngIndex)
Call Row_control(lngRow, intColumn, 1)
lngStart = lngRow + 1
End If
Call Row_control(lngRow, intColumn, 1)
Cells(lngRow, intColumn) = strName(lngIndex)
Next
Range(Cells(lngStart, intColumn), Cells(lngRow, intColumn)).Sort Key1:=Cells(lngStart, intColumn)
Call Row_control(lngRow, intColumn, 3)
With Cells(lngRow, intColumn)
.Value = "Dateien Gesamt: " & CStr(lngCount)
.Font.Bold = True
End With
Call Row_control(lngRow, intColumn, 1)
With Cells(lngRow, intColumn)
.Value = "Ordner Gesamt: " & CStr(lngFolder)
.Font.Bold = True
End With
Columns.AutoFit
Unload UserForm2
Application.ScreenUpdating = True
End Sub

Private Sub Arrange(lngBase_limit As Long, lngUpper_limit As Long, strName() As String, strPath() As String)
Dim lngIndex1 As Long, lngIndex2 As Long, strElement1 As String, strElement2 As String, strBuffer As String
lngIndex1 = lngBase_limit
lngIndex2 = lngUpper_limit
strBuffer = strPath(Fix(lngBase_limit + lngUpper_limit) / 2)
Do
Do While strPath(lngIndex1) < strBuffer
lngIndex1 = lngIndex1 + 1
Loop
Do While strBuffer < strPath(lngIndex2)
lngIndex2 = lngIndex2 - 1
Loop
If lngIndex1 <= lngIndex2 Then
strElement1 = strName(lngIndex1)
strElement2 = strPath(lngIndex1)
strName(lngIndex1) = strName(lngIndex2)
strPath(lngIndex1) = strPath(lngIndex2)
strName(lngIndex2) = strElement1
strPath(lngIndex2) = strElement2
lngIndex1 = lngIndex1 + 1
lngIndex2 = lngIndex2 - 1
End If
Loop Until lngIndex1 > lngIndex2
If lngBase_limit < lngIndex2 Then Call Arrange(lngBase_limit, lngIndex2, strName, strPath)
If lngIndex1 < lngUpper_limit Then Call Arrange(lngIndex1, lngUpper_limit, strName, strPath)
End Sub


Private Sub Row_control(lngRow As Long, intColumn As Integer, bytCount As Byte)
lngRow = lngRow + bytCount
If lngRow > 65536 Then
lngRow = 1
intColumn = intColumn + 1
Call Heading(intColumn)
End If
End Sub


Private Sub Heading(intColumn As Integer)
With Cells(1, intColumn)
.Value = "Files on Drive: " & Left$(strDrive, 1)
With .Font
.Size = 12
.Bold = True
End With
End With
End Sub

Grüße,
Martin
Anzeige

299 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige