"Alt Klasörleri" ve "Alt Klasörlerdeki Tüm Dosyaları" Listeleme

Public ui As Long
Sub SubHsr()
Dim soru As String

101    Dim klsrSec As Object
102    Dim klsrMsUstu, Dosya, yol As String
103    Set klsrSec = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasor seçin !", 1)
104    klsrMsUstu = CreateObject("WScript.Shell").SpecialFolders("Desktop")
105        If klsrSec Is Nothing Then GoTo 117
106        If klsrSec = "Masaüstü" Or Klasor = "Desktop" Then
107            yol = klsrMsUstu
108            AnaListe (yol)
109            AltListe (yol)
110        ElseIf klsrSec <> "Masaüstü" Then
111            yol = klsrSec.Items.Item.Path
112            AnaListe (yol)
113            AltListe (yol)
114        Else
115            GoTo 117
116        End If
117    Set klsrSec = Nothing: ui = 0
End Sub
Private Sub AnaListe(yol As String)
201 Dim Dosya As String
202 Cells.ClearContents
203 Range("A4") = "Dosya Yolu":             Range("B4") = "Dosya Adı"
206 Range("C4") = "Son Düzenleme Tarihi":
207 Dosya = Dir(yol & "\*.*")
208 ui = 4
209 While Dosya <> ""
210     DoEvents
211     ui = ui + 1
212     Cells(ui, 1) = yol
213     Cells(ui, 2) = Dosya
214     Call DosyaOzellikleri(yol & Application.PathSeparator & Dosya)
215     Dosya = Dir
216 Wend
End Sub
Private Sub AltListe(yol As String)
On Error Resume Next
301 Dim klsrAra, klsrLst As Object, Dosya, dsyTYl As String
302 Set klsrLst = CreateObject("Scripting.FileSystemObject").GetFolder(yol).SubFolders
303 On Error GoTo 316
304 For Each klsrAra In klsrLst
305     Dosya = Dir(klsrAra.Path & "\*.*")
306     While Dosya <> ""
307        DoEvents
308        ui = [a65000].End(3).Row + 1
309        Cells(ui, 1) = klsrAra.Path & "\"
310        Cells(ui, 2) = Dosya
311        Call DosyaOzellikleri(klsrAra.Path & Application.PathSeparator & Dosya)
312        Dosya = Dir
313     Wend
314     AltListe (klsrAra.Path)
315 Next
316 Set klsrAra = Nothing: Set klsrLst = Nothing
End Sub
Private Sub DosyaOzellikleri(dsyBak As String)
401 Dim DsSisKnt, Dosyam As Object
402 Set DsSisKnt = CreateObject("Scripting.FileSystemObject")
403 Set Dosyam = DsSisKnt.GetFile(dsyBak)
404 With Dosyam
405    ActiveSheet.Hyperlinks.Add Anchor:=Range("B" & ui), Address:=dsyBak
410    Range("C" & ui) = Format(.DateLastModified, "dd.mm.yyyy")
412 End With
413 Set DsSisKnt = Nothing
414 Set Dosyam = Nothing
End Sub

Sub CommandButton3_Click()

Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.self.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
Range("A2:B65000").ClearContents
Liste11 (Kaynak)
Set Klasor = Nothing
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub
Private Sub Liste11(yol As String)
Dim fL As Object, f As Object, Dosya As String, j As Long
Set fL = CreateObject("Scripting.FileSystemObject")
On Error GoTo sonraki
For Each f In fL.GetFolder(yol).subfolders
j = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A1:A" & Rows.Count)) + 1
Cells(j, 1) = yol & "\" & f.Name
Cells(j, 2) = f.Name

On Error Resume Next
Liste11 (f.Path)
sonraki:
Next
Set fL = Nothing
End Sub

Sub Dikdörtgen2_Tıkla()
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.self.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
Range("A2:B65000").ClearContents
Liste11 (Kaynak)
Set Klasor = Nothing
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub
Private Sub Liste11(yol As String)
Dim fL As Object, f As Object, Dosya As String, j As Long
Set fL = CreateObject("Scripting.FileSystemObject")
On Error GoTo sonraki
For Each f In fL.GetFolder(yol).subfolders
j = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A1:A" & Rows.Count)) + 1

Cells(j, 1) = f.Name

On Error Resume Next
Liste11 (f.Path)
sonraki:
Next
Columns("A").AutoFit
Set fL = Nothing
End Sub

Dim sut
Dim sat

Sub CommandButton3_Click()

Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.self.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
Cells.ClearContents
Liste11 (Kaynak)
sat = 0
For r = 2 To Cells(Rows.Count, "A").End(3).Row
sut = 2
sat = sat + 1
aranan = Cells(r, "a").Value
Liste12 (aranan)
Next r

Set Klasor = Nothing
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub
Private Sub Liste11(yol As String)
Dim fL As Object, f As Object, Dosya As String, j As Long
Set fL = CreateObject("Scripting.FileSystemObject")

For Each f In fL.GetFolder(yol).subfolders
j = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A1:A" & Rows.Count)) + 1
Cells(j, 1) = yol & "\" & f.Name
Cells(j, 2) = f.Name
Next
Set fL = Nothing
End Sub
Private Sub Liste12(yol As String)
Dim fL As Object, f As Object, Dosya As String, j As Long
Set fL = CreateObject("Scripting.FileSystemObject")
On Error GoTo sonraki
'sat = sat + 1
For Each f In fL.GetFolder(yol).subfolders
sut = sut + 1
Cells(sat, sut) = f.Name

On Error Resume Next
Liste12 (f.Path)
sonraki:
Next
Set fL = Nothing
End Sub

Dim sut
Dim sat
Dim say
Dim veri(1000)

Sub CommandButton3_Click()

Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.self.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
Cells.ClearContents
'Rows("2:500").ClearContents
Cells(1, 1) = "İSİMLER"
Cells(1, 2) = "ŞEHİRLER"
sut = 0
sat = 0
say = 0

Liste11 (Kaynak)
sat = 1
For r = 1 To say
sut = 1
sat = sat + 1
aranan = veri(r)
Liste12 (aranan)
Next r

Set Klasor = Nothing
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub
Private Sub Liste11(yol As String)
Dim fL As Object, f As Object, Dosya As String, j As Long
Set fL = CreateObject("Scripting.FileSystemObject")

For Each f In fL.GetFolder(yol).subfolders
say = say + 1
j = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A1:A" & Rows.Count)) + 1
veri(say) = yol & "\" & f.Name
Cells(j, 1) = f.Name
Next
Set fL = Nothing
End Sub
Private Sub Liste12(yol As String)
Dim fL As Object, f As Object, Dosya As String, j As Long
Set fL = CreateObject("Scripting.FileSystemObject")
On Error GoTo sonraki
'sat = sat + 1
For Each f In fL.GetFolder(yol).subfolders
sut = sut + 1
Cells(sat, sut) = f.Name

On Error Resume Next
Liste12 (f.Path)
sonraki:
Next
Set fL = Nothing
End Sub

Dim say
Dim veri1(1000)
Dim veri2(1000)
Dim aranan2

Sub CommandButton3_Click()

Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.self.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
Cells.ClearContents
'Rows("2:500").ClearContents
Cells(1, 1) = "İSİMLER"
Cells(1, 2) = "ŞEHİRLER"

say = 0

Liste11 (Kaynak)
For r = 1 To say
aranan1 = veri1(r)
aranan2 = veri2(r)
Liste12 (aranan1)
Next r

Set Klasor = Nothing
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub
Private Sub Liste11(yol As String)
Dim fL As Object, f As Object, Dosya As String, j As Long
Set fL = CreateObject("Scripting.FileSystemObject")

For Each f In fL.GetFolder(yol).subfolders
say = say + 1
'j = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A1:A" & Rows.Count)) + 1
veri1(say) = yol & "\" & f.Name
veri2(say) = f.Name
Next
Set fL = Nothing
End Sub
Private Sub Liste12(yol As String)
Dim fL As Object, f As Object, Dosya As String, j As Long
Set fL = CreateObject("Scripting.FileSystemObject")
On Error GoTo sonraki
For Each f In fL.GetFolder(yol).subfolders

j = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A1:A" & Rows.Count)) + 1
Cells(j, 1) = aranan2
Cells(j, 2) = f.Name
On Error Resume Next
Liste12 (f.Path)
sonraki:
Next
Set fL = Nothing
End Sub

Sub Oval3_Tıkla()
Columns("A:B").ClearContents
Set Klasor = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasor seçin !", 1)
If Klasor Is Nothing Then MsgBox "Klasör Seçmediniz", vbInformation + vbMsgBoxRtlReading, "İptal Edildi": Exit Sub
For Each ana In CreateObject("Scripting.FileSystemObject").GetFolder(Klasor.items.Item.Path).subfolders
For Each alt In CreateObject("Scripting.FileSystemObject").GetFolder(ana).subfolders
sat = sat + 1
Cells(sat + 1, 1) = ana.Name
Cells(sat + 1, 2) = alt.Name
Next alt, ana
Cells(1, 1).Resize(1, 2) = Array("İSİMLER", "ŞEHİRLER")
MsgBox "İşlem Tamamlandı",
End Sub