Option Explicit
Sub Dateisuche()
Dim Suche As String, Suche2 As String
Dim lngLast As Long
Suche = InputBox("Bitte Suchbegriff eingeben", Suche)
If Suche <> "" Then
Suche2 = InputBox("Bitte gesuchte Dateiendung eingeben", Suche2)
If Suche2 <> "" Then
lngLast = ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
ThisWorkbook.Sheets("Sheet1").Range("A2:A" & lngLast).ClearContents
LoopThroughFolder "\\murplfp01\Workgroups\Frontline Managers\Presentations", Suche, Suche2
End If
End If
End Sub
Public Sub LoopThroughFolder(path As String, Filter As Variant, Filter2 As Variant)
Dim fso, oFolder, oSubfolder, oFile, queue As Collection
Dim lngLast As Long
On Error Resume Next
Set fso = CreateObject("Scripting.FileSystemObject")
Set queue = New Collection
queue.Add fso.GetFolder(path)
Do While queue.Count > 0
Set oFolder = queue(1)
queue.Remove 1
For Each oSubfolder In oFolder.SubFolders
If oSubfolder <> vbEmpty Then queue.Add oSubfolder
Next
For Each oFile In oFolder.Files
If oFile <> vbEmpty Then
If InStr((oFile.Name), Filter) <> 0 Then
If InStr((oFile.Name), Filter2) <> 0 Then
With ThisWorkbook.Sheets("Sheet1")
lngLast = .Cells(Rows.Count, 1).End(xlUp).Row + 1
.Hyperlinks.Add anchor:=.Cells(lngLast, 1), Address:=oFile.path, TextToDisplay:=oFile.Name
End With
End If
End If
End If
Next
Loop
End Sub