AW: per Dateiname suchen
20.01.2023 13:51:14
Marcus
Entschuldigung, habe mich wie schon des öffteren falsch und zu knapp ausgedrückt.
Ich habe Ordner von Mitgliedern (ca 4500) in jedem Ordner gibt es eine Datei mit dem Namen Einkaufsliste.
Mein Wunsch wäre alle Ordner der Mitglieder nach der Datei Einkaufsliste zu durchsuchen und mir hieraus eine Excelliste mit Hyperlinks zu den Dateien zu erstellen.
Mein Problem ist das es xls xlsm pdf sein können. Die von mir gefunden Codes hängen sich eigentlich alle auf.
Z.B.
Option Explicit
Dim wksStart As Worksheet, wksInhalt As Worksheet, vntFiles(), lngFiles As Long
Dim strSuch As String
Sub prcFolders()
Dim FSO As Object, oFolder As Object
Dim strFolder As String
Application.ScreenUpdating = False
Set wksStart = ThisWorkbook.Sheets("Start")
On Error Resume Next
Set wksInhalt = ThisWorkbook.Sheets("Inhalt")
On Error GoTo 0
If wksInhalt Is Nothing Then
Set wksInhalt = Worksheets.Add
wksInhalt.Name = "Inhalt"
End If
Set FSO = CreateObject("Scripting.FileSystemObject")
strFolder = wksStart.Cells(1, 2)
If strFolder = "" Then
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "c:\" 'anpassen
If .Show = -1 Then
strFolder = .SelectedItems(1)
End If
End With
End If
If strFolder = "" Then Exit Sub
strSuch = Application.InputBox("Dateiname?", "Suchbegriff")
If strSuch = "Falsch" Then Exit Sub
strSuch = LCase("*" & strSuch & "*")
Set oFolder = FSO.getfolder(strFolder)
lngFiles = 1
With wksInhalt
.Range("A:C").ClearContents
.Cells(1, 1) = "Pfad"
.Cells(1, 2) = "Dateiname"
.Range(.Cells(1, 1), .Cells(1, 3)).Font.Bold = True
End With
prcFiles oFolder
prcSubFolders oFolder
With wksInhalt
.Range(.Cells(2, 1), .Cells(lngFiles, 2)).FormulaLocal = WorksheetFunction.Transpose(vntFiles)
.Activate
End With
End Sub
Sub prcSubFolders(oFolder)
Dim oSubFolder As Object
For Each oSubFolder In oFolder.subfolders
prcFiles oSubFolder
prcSubFolders oSubFolder
Next
End Sub
Sub prcFiles(oFolder)
Dim oFile As Object
For Each oFile In oFolder.Files
If LCase(oFile.Name) Like strSuch Then
ReDim Preserve vntFiles(1 To 2, 1 To lngFiles)
vntFiles(1, lngFiles) = oFolder.Path
vntFiles(2, lngFiles) = "=hyperlink(""" & oFile.Path & """;""" & oFile.Name & """)"
lngFiles = lngFiles + 1
End If
Next
End Sub