AW: Datei suchen
18.02.2016 19:06:56
Piet
Hallo Hartmut
ich kenne den Code von Nepumuk, verstanden habe ich ihn nicht.
Anbei ein wesentlich kürzer Code aus meinem Thread:
Ordner mir U-Ordner + Dateien einlesen - Piet 15.02.2016 14:57:01
AW: Ordner einlesen - von Rudi Maintaire am 16.02.2016 10:29:19
Der Dank gebürt Rudi Maintaire. Er listet zwar alles auf, ist aber egal
Man findet die Datei auf jeden Fall im Ordner. Danke an Rudi ....
mfg Piet
Option Explicit
Sub DateiListe()
Dim FSO As Object, oFolder As Object, oDictF As Object
Dim strFolder As String, arrHeader, wksListe As Worksheet
Dim lngColumns As Long
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
prcFiles oFolder, oDictF
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
'korerektur
If oDictF.Count > 0 Then
.Cells(2, 1).Resize(oDictF.Count, lngColumns).FormulaLocal _
= WorksheetFunction.Transpose(WorksheetFunction.Transpose(oDictF.Items))
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
For Each oFile In oFolder.Files
With oFile
oDictF(.Path) = Array( _
Left(.Name, InStrRev(.Name, ".") - 1), _
Replace(.Name, Left(.Name, InStrRev(.Name, ".")), ""), _
oFolder, _
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
'Gruß
'Rudi