Dateien aus Ordner auslesen - #NV

[xlsxvba]

Hallo,
ich bin neu hier im Forum und habe eine Frage bzgl. eines Makros, das ich gefunden habe auf [url=
Dateiupload bitte im Forum! So geht es: Klick mich!
]
Das Makro listet Details zu den Dateien innerhalb eines ausgewählten Ordners auf. Sind z.B. nur 5 Dateien enthalten, werden trotzdem 65000 Zeilen mit "#NV" gefüllt.
Leider kann ich nicht herauslesen, an welcher Stelle dies im Code geschieht.
Könntet ihr mir sagen, wie ich das vermeide, sodass nur entsprechend der Anzahl an Dateien im Ordner die Zeilen im Worksheet befüllt werden?
Vielen Dank!
Gruß Herbert

Code:

Option Explicit
Public x()
Public i As Long
Public objShell, objFolder, objFolderItem
Public FSO, oFolder, Fil
Sub MainExtractData()
  Dim NewSht As Worksheet
  Dim MainFolderName As String
  Dim TimeLimit As Long, StartTime As Double
  ReDim x(1 To 65536, 1 To 11)
  Set objShell = CreateObject("Shell.Application")
  TimeLimit = Application.InputBox("Please enter the maximum time that you wish this code to run for in minutes" & vbNewLine & vbNewLine & _
      "Leave this at zero for unlimited runtime", "Time Check box", 0)
  StartTime = Timer
  Application.ScreenUpdating = False
  MainFolderName = BrowseForFolder()
  Set NewSht = ThisWorkbook.Sheets.Add
  x(1, 1) = "Path"
  x(1, 2) = "File Name"
  x(1, 3) = "Last Accessed"
  x(1, 4) = "Last Modified"
  x(1, 5) = "Created"
  x(1, 6) = "Type"
  x(1, 7) = "Size"
  x(1, 8) = "Owner"
  x(1, 9) = "Author"
  x(1, 10) = "Title"
  x(1, 11) = "Comments"
  i = 1
  Set FSO = CreateObject("scripting.FileSystemObject")
  Set oFolder = FSO.GetFolder(MainFolderName)
  'error handling to stop the obscure error that occurs at time when retrieving DateLastAccessed
  On Error Resume Next
  For Each Fil In oFolder.Files
    Set objFolder = objShell.Namespace(oFolder.Path)
    Set objFolderItem = objFolder.ParseName(Fil.Name)
    i = i + 1
    If i Mod 20 = 0 And TimeLimit <> 0 And Timer > (TimeLimit * 60 + StartTime) Then
      GoTo FastExit
    End If
    If i Mod 50 = 0 Then
      Application.StatusBar = "Processing File " & i
      DoEvents
    End If
    x(i, 1) = oFolder.Path
    x(i, 2) = Fil.Name
    x(i, 3) = Fil.DateLastAccessed
    x(i, 4) = Fil.DateLastModified
    x(i, 5) = Fil.DateCreated
    x(i, 6) = Fil.Type
    x(i, 7) = Fil.Size
    x(i, 8) = objFolder.GetDetailsOf(objFolderItem, 8)
    x(i, 9) = objFolder.GetDetailsOf(objFolderItem, 9)
    x(i, 10) = objFolder.GetDetailsOf(objFolderItem, 10)
    x(i, 11) = objFolder.GetDetailsOf(objFolderItem, 14)
  Next
  'Get subdirectories
  If TimeLimit = 0 Then
    Call RecursiveFolder(oFolder, 0)
  Else
    If Timer < (TimeLimit * 60 + StartTime) Then Call RecursiveFolder(oFolder, TimeLimit * 60 + StartTime)
  End If
FastExit:
  Range("A:K") = x
  If i < 65535 Then Range(Cells(i + 1, "A"), Cells(65536, "A")).EntireRow.Delete
  Range("A:K").WrapText = False
  Range("A:K").EntireColumn.AutoFit
  Range("1:1").Font.Bold = True
  Rows("2:2").Select
  ActiveWindow.FreezePanes = True
  Range("a1").Activate
  Set FSO = Nothing
  Set objShell = Nothing
  Set oFolder = Nothing
  Set objFolder = Nothing
  Set objFolderItem = Nothing
  Set Fil = Nothing
  Application.StatusBar = ""
  Application.ScreenUpdating = True
End Sub
Sub RecursiveFolder(xFolder, TimeTest As Long)
  Dim SubFld
  For Each SubFld In xFolder.SubFolders
    Set oFolder = FSO.GetFolder(SubFld)
    Set objFolder = objShell.Namespace(SubFld.Path)
    For Each Fil In SubFld.Files
      Set objFolder = objShell.Namespace(oFolder.Path)
      'Problem with objFolder at times
      If Not objFolder Is Nothing Then
        Set objFolderItem = objFolder.ParseName(Fil.Name)
        i = i + 1
        If i Mod 20 = 0 And TimeTest <> 0 And Timer > TimeTest Then
          Exit Sub
        End If
        If i Mod 50 = 0 Then
          Application.StatusBar = "Processing File " & i
          DoEvents
        End If
        x(i, 1) = SubFld.Path
        x(i, 2) = Fil.Name
        x(i, 3) = Fil.DateLastAccessed
        x(i, 4) = Fil.DateLastModified
        x(i, 5) = Fil.DateCreated
        x(i, 6) = Fil.Type
        x(i, 7) = Fil.Size
        x(i, 8) = objFolder.GetDetailsOf(objFolderItem, 8)
        x(i, 9) = objFolder.GetDetailsOf(objFolderItem, 9)
        x(i, 10) = objFolder.GetDetailsOf(objFolderItem, 10)
        x(i, 11) = objFolder.GetDetailsOf(objFolderItem, 14)
        Debug.Print x(i, 1), x(i, 2), x(i, 11)
      Else
        Debug.Print Fil.Path & " " & Fil.Name
      End If
    Next
    Call RecursiveFolder(SubFld, TimeTest)
  Next
End Sub
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
  'Function purpose:  To Browser for a user selected folder.
  'If the "OpenAt" path is provided, open the browser at that directory
  'NOTE:  If invalid, it will open at the Desktop level
  Dim ShellApp As Object
  'Create a file browser window at the default folder
  Set ShellApp = CreateObject("Shell.Application"). _
      BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
  'Set the folder to that selected.  (On error in case cancelled)
  On Error Resume Next
  BrowseForFolder = ShellApp.self.Path
  On Error GoTo 0
  'Destroy the Shell Application
  Set ShellApp = Nothing
  'Check for invalid or non-entries and send to the Invalid error
  'handler if found
  'Valid selections can begin L: (where L is a letter) or
  '\\ (as in [url=file://servernamesharename]\\servername\sharename[/url].  All others are invalid
  Select Case Mid(BrowseForFolder, 2, 1)
    Case Is = ":"
      If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
    Case Is = "\"
      If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
    Case Else
      GoTo Invalid
  End Select
  Exit Function
Invalid:
  'If it was determined that the selection was invalid, set to False
  BrowseForFolder = False
End Function

[Kuwer]

Hallo Herbert,

ersetze in der Prozedur MainExtractData

 Range("A:K") = x

durch

 Range("A1:K" & i) = x

Gruß Uwe

[Glausius]

Hallo Herbert, Hallo Uwe,

besser ist

Range("A1:K" & i - 1) = x

ansonsten enthält die letzte Zeile ebenfalls noch das #NV.

[xlsxvba]

Moin Uwe!

Besten Dank!! Funktioniert! :)

Jetzt hätte ich nur noch ein paar Fragen zur Optimierung:

1. Wie kann ich den Input also in diesem Falle die Spaltenbeschriftungen in Zeile 4 beginnen lassen?
2. Ich habe festgestellt, dass manche Dateien verkürzt mit Tilde (~) angegeben werden. Kann man sich den vollen Namen zurück geben lassen?

Vielen Dank auf jeden Fall für deine erste Lösung schon einmal!!

@Glausius: bei mir kamen keine #NVs mehr. Aber ich teste auch deinen Vorschlag gleich mal.
Danke auch an dich!

Gruß,
Herbert

[xlsxvba]

Hallo Herbert, Hallo Uwe,

besser ist

Range("A1:K" & i - 1) = x

ansonsten enthält die letzte Zeile ebenfalls noch das #NV.

Also wenn ich das -1 mit eintrage, werden Unterordner nicht mehr mitgezählt ...

[Kuwer]

Hallo Herbert, hallo Günter,

die -1 wäre falsch, da dann die letzte Zeile des Arrays x nicht in die Zellen übertragen wird, weil das Array x nicht nullbasiert ist (die Zählung nicht mit 0 beginnt).

Gruß Uwe

[Kuwer]

Hallo Herbert,

zu 1:

Ändere den Schluss so:

Code:

FastExit:
With Range("A4").Resize(i, 11)
   .Value = x
   .WrapText = False
   .EntireColumn.AutoFit
   .Rows(1).Font.Bold = True
   .Rows(2).Select
   ActiveWindow.FreezePanes = True
   .Range("a1").Activate
 End With
 Set FSO = Nothing
 Set objShell = Nothing
 Set oFolder = Nothing
 Set objFolder = Nothing
 Set objFolderItem = Nothing
 Set Fil = Nothing
 Application.StatusBar = ""
 Application.ScreenUpdating = True
End Sub

Zu 2:

Wenn eine Tilde erscheint, ist diese wohl schon fest im Namen drin!?

Gruß Uwe

[xlsxvba]

Danke für eure Antworten!
Die letzte Lösung ist auch noch etwas eleganter!

Die Tilde kommt wohl nur, wenn ich das Verzeichnis auslese, in dem die Excel Datei selber liegt. Ich denke mal, dass es diese versteckte Datei ist.

Danke und viele Grüße!

[Rabe]

Die Tilde kommt wohl nur, wenn ich das Verzeichnis auslese, in dem die Excel Datei selber liegt. Ich denke mal, dass es diese versteckte Datei ist.

die Tilde kommt daher, daß es eine temporäre Datei ist, die versteckt im Ordner liegt, z.B. eine geöffnete Datei.
Das siehst Du auch daran, daß es die Datei 2 mal gibt, ein Mal das Original und dann die mit Tilde.

Wenn Excel abstürzt, bleibt die temporäre Datei im Verzeichnis liegen.

Zwei weitere Sachen wären auch noch schön:

1. wenn die Pfadauswahl eine direkte Pfgadeingabe erlauben würde
   
2. wenn es am Ende einen Link auf die Datei in jeder Zeile gäbe
   

[Kuwer]

Hi Ralf,

Pfad mit Abfrage
 MainFolderName = BrowseForFolder()
fester Pfad
 MainFolderName = "C:\Users\Uwe\Pictures\"

 Dateiname als Text
   x(i, 2) = Fil.Name
 Dateiname als Hyperlink
   x(i, 2) = "=HYPERLINK(""" & Fil.Path & """,""" & Fil.Name & """)"

Gruß Uwe