Excel lässt Daten im Ordnerobject aus

Hallo liebes Herber Forum,
ich arbeite gerade an einer Iterativen Auflistung eines Windows-Verzeichnisses. Dabei ist mir aufgefallen, dass Excel manchmal Files auslässt.
Ich habe also ein FSO und dadurch einen Folder
z.B. Ordner=FSO.GetFolder(Verzeichnis)
dann Prüfe ich ob dieser Ordner Files hat:
If Ordner.Files > 0 then
For Each Datei in Ordner.Files
Cells(i,j).Value = Datei.Name
i=i+1
Next
End If
Folgendes Problem zeigt sich beim Debugen: Excel erkennt, dass ein bestimmtes Verzeichnis Dateien hat, in meinem Fall sind es zwei pdf´s die im Ordner "Verzeichnis" liegen. Es springt also in die If-Abfrage rein.
Kommt es jedoch zur For Schleife, dann überspringt Excel diese.
Sowohl im Watcher als auch tatsächlich im Ordner kann ich zwei Dateien erkennen. Also wenn ich mir Ordner.Files.count ansehe, dann steht da eine 2.
Warum kann Excel diese Dateien nicht "Greifen"?
Vielen Dank im voraus.
Freundliche Grüße
Reinhold Fregin

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Dim FSO As Object Sub DateiListe() Dim oFolder As Object, oDictF As Object Dim strFolder As String, arrHeader, wksListe As Worksheet Dim lngColumns As Long Dim arrItems, arrOut, i As Integer, j As Integer Application.ScreenUpdating = False With Application.FileDialog(msoFileDialogFolderPicker) .Title = "Ordner wählen" .AllowMultiSelect = False If .Show = -1 Then strFolder = .SelectedItems(1) End If End With If strFolder = "" Then Exit Sub Set FSO = CreateObject("Scripting.FileSystemObject") Set oFolder = FSO.GetFolder(strFolder) Set oDictF = CreateObject("Scripting.dictionary") arrHeader = Array("Name", "Ext", "Ordner", "kB", "le.Änd.", "Erstellt", "Pfad", "Link") lngColumns = UBound(arrHeader) + 1 Call prcFiles(oFolder, oDictF) Call prcSubFolders(oFolder, oDictF) On Error Resume Next Set wksListe = ThisWorkbook.Sheets("DateiListe") On Error GoTo 0 If wksListe Is Nothing Then Set wksListe = Worksheets.Add(before:=Sheets(1)) wksListe.Name = "DateiListe" End If With wksListe .Cells.Clear .Cells(1, 1).Resize(, lngColumns) = arrHeader .Cells(1, 1).Resize(, lngColumns).Font.Bold = True If oDictF.Count > 0 Then arrItems = oDictF.items ReDim arrOut(1 To oDictF.Count, 1 To lngColumns) For i = 0 To UBound(arrItems) For j = 0 To UBound(arrItems(i)) arrOut(i + 1, j + 1) = arrItems(i)(j) Next j Next i .Cells(2, 1).Resize(UBound(arrOut), UBound(arrOut, 2)).FormulaLocal = arrOut Else With .Cells(2, 1) .Value = "No Files in " & oFolder With .Font .Bold = True .Size = 16 .Color = RGB(255, 0, 0) End With End With End If .Columns.AutoFit .Activate End With End Sub Sub prcFiles(oFolder, oDictF) Dim oFile As Object ', sEXT As String For Each oFile In oFolder.Files With oFile oDictF(.Path) = Array( _ Left(.Name, InStrRev(.Name, ".") - 1), _ Replace(.Name, Left(.Name, InStrRev(.Name, ".")), ""), _ oFolder.Name, _ Int(.Size / 1024), _ .DateLastModified, _ .DateCreated, _ .Path, _ "=HYPERLINK(""" & .Path & """;""" & "Klick" & """)") End With Next End Sub Sub prcSubFolders(oFolder, oDictF) Dim oSubFolder As Object For Each oSubFolder In oFolder.SubFolders prcFiles oSubFolder, oDictF prcSubFolders oSubFolder, oDictF Next End Sub

Leider löst dein Tool mein Problem nicht. Ich habe es mit einem Verzeichnis ausprobiert, welches ca 20 pdf´s hat. Dein Tool listet allerdings nur zwei der PDF´s auf. (Mein Tool im Übrigen auch)
Hier mal mein Code
<pre>Sub Ordneranalysetool_2_Ebene()
Dim SO As Object
Dim Ordner As Object
Dim Datei As Object
Dim SF As Object
Dim Sheet As Object
Dim Temp As Object
Dim DVerzeichnis() As Variant
Dim OVerzeichnis() As Variant
Dim i, j, f, x As Long
Dim zSF, z, k As Long
Dim Frage As Long
Dim Anzahl As Long
Dim b As Integer
z = 0
k = 10000
Verzeichnis = ThisWorkbook.Worksheets("Makro").Cells(9, 3).Value
Ebene1 = ThisWorkbook.Worksheets("Makro").Cells(10, 3).Value
Set SO = CreateObject("Scripting.FileSystemObject")
Set Sheet = Sheets.Add
Sheet.Activate
y = 1000
On Error Resume Next
ActiveSheet.Name = VBA.Date & "_" & ThisWorkbook.Worksheets("Makro").Cells(11, 3).Value
ActiveSheet.Cells(10, 5).Value = Verzeichnis
ActiveSheet.Cells(10, 5).Activate
i = ActiveCell.row
j = ActiveCell.Column
zSF = ActiveCell.row
Application.ScreenUpdating = False
Do While Cells(i, j).Value <> ""
Set Ordner = SO.GetFolder(Cells(i, j).Value)
If Ordner.Files.Count > 0 Then
Anzahl = Ordner.Files.Count
For Each Temp In Ordner.Files
If Dir(Temp.Path, vbHidden) = "" Then
Anzahl = Anzahl - 1
End If
Next
OVerzeichnis
If Anzahl > 0 Then
Range(Rows(i + 1), Rows(i + Anzahl)).Insert
End If
If Ordner.Files.Count > 10 Then
ReDim DVerzeichnis(4, Anzahl - 1)
For Each Datei In Ordner.Files
If Dir(Datei.Path, vbHidden) <> "" Then
DVerzeichnis(0, f) = Datei.Name
DVerzeichnis(1, f) = "Datei"
DVerzeichnis(2, f) = Datei.DateLastModified
DVerzeichnis(3, f) = Datei.Size
DVerzeichnis(4, f) = Datei.ParentFolder.Path
z = z + 1
End If
f = f + 1
Next
If f <> Anzahl Then
For f = 0 To Ordner.Files.Count - 1
If DVerzeichnis(0, f) = Empty Then
DVerzeichnis(0, f) = "Datei konnte nicht erfasst werden"
DVerzeichnis(4, f) = Cells(i, j).Value
End If
Next
End If
If Anzahl = 1 Then
DVerzeichnis = Application.WorksheetFunction.Transpose(DVerzeichnis)
'Debug.Print UBound(DVerzeichnis, 1)
Cells(i + 1, 1).Resize(1, 5).Value = DVerzeichnis()
z = z + 1
Else
DVerzeichnis = Application.WorksheetFunction.Transpose(DVerzeichnis)
'Debug.Print UBound(DVerzeichnis, 1)
Cells(i + 1, 1).Resize(UBound(DVerzeichnis), 5).Value = DVerzeichnis()
z = z + Ordner.Files.Count
End If
f = 0
DoEvents
Application.StatusBar = z & " Zellen wurden beschrieben"
i = i + Anzahl
ReDim DVerzeichnis(0)
Else
b = Anzahl
For Each Datei In Ordner.Files
If Dir(Datei.Path, vbHidden) <> "" Then
i = i + 1
b = b - 1
Cells(i, 1).Value = Datei.Name
Cells(i, 2).Value = "Datei"
Cells(i, 3).Value = Datei.DateLastModified
Cells(i, 4).Value = Datei.Size
Cells(i, j).Value = Datei.ParentFolder.Path
z = z + 1
DoEvents
Application.StatusBar = z & " Zellen wurden beschrieben"
End If
Next
If b <> 0 Then
For b = b To 1 Step -1
i = i + 1
Cells(i, 1).Value = "Datei konnte nicht erfasst werden"
Cells(i, j).Value = Cells(i - 1, j).Value
Next
End If
End If
End If
If Ordner.SubFolders.Count > 0 Then
' For x = 1 To Ordner.subfolders.Count
' Cells(i + 1, j).EntireRow.Insert
' Next
Range(Rows(i + 1), Rows(i + Ordner.SubFolders.Count)).Insert
End If
'k = 50000
zSF = i
For Each SF In Ordner.SubFolders
zSF = zSF + 1
Cells(zSF, j).Value = SF.Path
z = z + 1
Application.StatusBar = z & " Zellen wurden beschrieben"
Next
DoEvents
i = i + 1
If z > k Then
k = k + 50000
Frage = MsgBox(z & " Zeilen wurden beschrieben, Fortfahren?", vbYesNo)
Select Case Frage
Case vbYes: Resume Next
Case vbNo: MsgBox ("nein")
Exit Sub
End Select
End If
Loop
Application.StatusBar = ""
Application.ScreenUpdating = True
MsgBox ("Verzeichnis ist " & z & " Zeilen gro?")
Set Datei = Nothing
Set Ordner = Nothing
End Sub</pre>

Beliebteste Forumthreads (12 Monate)

Excel lässt Daten im Ordnerobject aus

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread