Selamlar,
Alt klasör listeleme hakkinda ki tüm aciklamalari okudum ancak hepsinde alt klasörlerin tümünü listeleme üzerinden aciklamalar yapilmis veya kodalar yazilmi.Benim takildigim nokta ise. Sadece 2 veya 3 alt klasöre gidip orada bir listeleme yapmak aslinda yapmak istedigim döngünün belli bir yere kadar ilerlemesi fakat kodlarda döngüyü yarida nasil kesebilecegimi bir türlü bulamadim.Bu konuda yardimci olabilecek biri cikarsa cok sevinirim.
Örnegin bu Halit beyin bu kodunda tüm klasörler listeleniyor ben ikinci alt klasöre kadar ilerlemesini istiyorum.
Sub deneme()
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:c65000").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
Cells(j, 3) = CreateObject("Scripting.FileSystemObject").GetFolder(f.Path).DateLastModified
On Error Resume Next
Liste11 (f.Path)
sonraki:
Next
Set fL = Nothing
End Sub
Alt klasör listeleme hakkinda ki tüm aciklamalari okudum ancak hepsinde alt klasörlerin tümünü listeleme üzerinden aciklamalar yapilmis veya kodalar yazilmi.Benim takildigim nokta ise. Sadece 2 veya 3 alt klasöre gidip orada bir listeleme yapmak aslinda yapmak istedigim döngünün belli bir yere kadar ilerlemesi fakat kodlarda döngüyü yarida nasil kesebilecegimi bir türlü bulamadim.Bu konuda yardimci olabilecek biri cikarsa cok sevinirim.
Örnegin bu Halit beyin bu kodunda tüm klasörler listeleniyor ben ikinci alt klasöre kadar ilerlemesini istiyorum.
Sub deneme()
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:c65000").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
Cells(j, 3) = CreateObject("Scripting.FileSystemObject").GetFolder(f.Path).DateLastModified
On Error Resume Next
Liste11 (f.Path)
sonraki:
Next
Set fL = Nothing
End Sub