Çözüldü Klasör içindeki klasörleri listeleme

[schlecht]

Merhaba,

Forumda arama yaptım genelde klasör içindeki dosya isimleri listeleme konuları işlenmiş. Klasör içindeki klasör isimlerini A sütunua, Değiştirme tarihini ise B sütunua yazdırmak istiyorum. Yardımcı olursanız sevinirim.

İyi çalışmalar...

 

[schlecht]

Sub Klasor_altklasor_listesi()
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder("C:\Dosya")
Set colSubfolders = objFolder.SubFolders

For Each objSubfolder In colSubfolders
k = k + 1

Cells(k, "z") = objSubfolder.Name

Next

End sub

ile klasör isimlerini aldım. Fakat tarihleri alacak bir kod bulamadım.

 

[halit3]

aşağıdaki linke bir bakınız

https://www.excel.web.tr/threads/klasoer-icindeki-dosya-ve-klasoer-oezelliklerini-listelemek.77778/

 

[halit3]

farklı bir kod

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

 

[schlecht]

Sayın halit3 çok teşekkür ederim. Dosyayı seçimlik değilde sabit bir dosya yapabilirmisiniz?

 

[halit3]

KOD

Sub deneme()

Kaynak = "D:\"

Range("A2:c65000").ClearContents
Liste11 (Kaynak)
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

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

 

[schlecht]

Hocam çok teşekkürler. Çok işeme yaradı inanın. Müsaitseniz son bir ricam olacak. Klasör ismi "Kitap" olanı listelemese

If folder.Name <> "Kitap" Then
Cells(j, "Kitap") = folder.Name
End If

bir yerde hata yaptım ama çözemedim.

 

[halit3]

kod

Sub deneme()

Kaynak = "D:\"

Range("A2:c65000").ClearContents
Liste11 (Kaynak)
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
If f.Name <> "Kitap" Then
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
End If

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

 

[schlecht]

Elinize sağlık hocam

 

[halit3]

Teşekkürler iyi çalışmalar

 

[Comser]

Halit hocam merhaba,
yukaridaki kodlar oldukca faydali,ancak bir sorum olacak.Kodlarda tüm alt klasorlere gidiyor program.Yalnizca iki alt klasore gitmesini yada x'inci alt klasore gitmesini ve o klasorün adini ve icindeki dosya uzantilarina erismek istedigimizde;

If InStr(1, Kaynak, "{") > 0

Bu kismami müdehale etmemiz gerecek.Yanitiniz icin simdiden tesekkürler.kolay gelsin.