Çalışma Microsoft Scripting Runtime referansını gerektirir.
İsteğe göre uzantı belirtebilirsiniz, örnekte "xls" belirtmiştim.
Eğer belirtmezseniz, ayrım yapmadan listeler.
Kod:
Dim Yol As String
Dim Listelendi As Boolean
Dim FSO As FileSystemObject
Dim Dizin As Folder, AltKlasor As Folder, Dosya As File
Dim Say As Integer, Uzanti As String, Dosya1 As String
Sub Listele()
Yol = "F:\PC\XLS"
If Right(Yol, 1) <> "\" Then Yol = Yol & "\"
Dosya_Listele Yol, "xls"
If Listelendi Then
MsgBox "Dosyalar listelendi.", vbInformation, "Sonuç"
Else: MsgBox "Dosyalar listelenmedi." & vbCrLf & "Belirtilen klasör mevcut değil.", vbInformation, "Sonuç"
End If
End Sub
Sub Dosya_Listele(Klasor As String, Optional Kriter As String)
'Microsoft Scripting Runtime gerektirir
If Len(Dir(Yol)) > 0 Then
Set FSO = New FileSystemObject
Set Dizin = FSO.GetFolder(Klasor)
For Each Dosya In Dizin.Files
If Kriter = "" Then
Say = WorksheetFunction.CountA(Sheets(1).Range("A:A")) + 1
Range("A" & Say) = Dosya
Else
Uzanti = Right(Dosya, 3)
Dosya1 = Dir(Dosya)
If InStr(1, Dosya1, Kriter, vbTextCompare) > 0 Then
Say = WorksheetFunction.CountA(Sheets(1).Range("A:A")) + 1
Range("A" & Say) = Dosya1
End If
End If
Next
For Each AltKlasor In Dizin.SubFolders
Dosya_Listele AltKlasor.Path, Kriter
Next AltKlasor
Listelendi = True
Set FSO = Nothing
Set Dizin = Nothing
Else:
Listelendi = False
End If
End Sub