Soru Sadece Alt Klasörleri Listeme

[schlecht]

Forumda arama yaptım fakat ihtiyacım olana benzer bir örnek bulamadım. Ekte bulunan Personel isimdi klasörün alt klasörlerini excelde listemek istiyorum dosya ismi ve konumu sabit olacak.

 

[halit3]

KOD:

Dim sat
Private Sub CommandButton1_Click()
sat = 2
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

Worksheets(ActiveSheet.Name).Range("A2:B" & Rows.Count).ClearContents

For Each Dosya In CreateObject("Scripting.FileSystemObject").GetFolder(Kaynak).SubFolders
If Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"
Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")
Liste11 (Kaynak & Dosya.Name)
Next

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

Cells(sat, 1) = fL.GetBaseName(yol)
Cells(sat, 2) = f.Name
sat = sat + 1
Liste11 (f.Path)
sonraki:
Next
Set fL = Nothing
End Sub

 

[schlecht]

halit3 hocam teşekkürler. Elinize sağlık.

 

[schlecht]

Hocam peki dosya yolunu sabit hale getirmemiz mümkün mü ?

 

[EmrExcel16]

Aşağıdaki gibi deneyiniz , C:\Desktop\Personel kısmını kendinize göre uyarlayınız.

Kodlar "halit3" 'e aittir ben sadece kaynak seçimini sabit hale getirdim.

Dim sat
Private Sub CommandButton1_Click()
sat = 2
Set Klasor = CreateObject("Scripting.FileSystemObject").GetFolder("C:\Desktop\Personel")
'Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla

Worksheets(ActiveSheet.Name).Range("A2:B" & Rows.Count).ClearContents

For Each Dosya In CreateObject("Scripting.FileSystemObject").GetFolder(Kaynak).SubFolders
If Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"
Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")
Liste11 (Kaynak & Dosya.Name)
Next

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

Cells(sat, 1) = fL.GetBaseName(yol)
Cells(sat, 2) = f.Name
sat = sat + 1
Liste11 (f.Path)
sonraki:
Next
Set fL = Nothing
End Sub

 

[halit3]

Alternatif kod
kodun olduğu dosya klasörlerin hemen yanında olsun

Dim sat
Sub deneme()
sat = 2

Kaynak = ThisWorkbook.Path
Worksheets(ActiveSheet.Name).Range("A2:B" & Rows.Count).ClearContents
For Each Dosya In CreateObject("Scripting.FileSystemObject").GetFolder(Kaynak).SubFolders
Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")
Liste11 (Kaynak & "\" & Dosya.Name)
Next
MsgBox "işlem tamam"

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
Cells(sat, 1) = fL.GetBaseName(yol)
Cells(sat, 2) = f.Name
sat = sat + 1
Liste11 (f.Path)
sonraki:
Next
Set fL = Nothing
End Sub