Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

Excel lässt Daten im Ordnerobject aus

Betrifft: Excel lässt Daten im Ordnerobject aus von: Reinhold
Geschrieben am: 23.09.2020 08:49:48

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



Betrifft: AW: Excel lässt Daten im Ordnerobject aus
von: Reinhold
Geschrieben am: 23.09.2020 08:52:52

If Ordner.Files.count > 0 then
Soll Das natürlich heißen. Sorry

Betrifft: AW: Excel lässt Daten im Ordnerobject aus
von: Rudi Maintaire
Geschrieben am: 23.09.2020 11:05:20

Hallo,
als Beispiel:
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


Betrifft: AW: Excel lässt Daten im Ordnerobject aus
von: Reinhold
Geschrieben am: 23.09.2020 11:46:36

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>