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

schlecht

Altın Üye
Katılım
13 Kasım 2009
Mesajlar
337
Excel Vers. ve Dili
Ofis 2016 TR 64 Bit
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

Altın Üye
Katılım
13 Kasım 2009
Mesajlar
337
Excel Vers. ve Dili
Ofis 2016 TR 64 Bit
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

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,758
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
farklı bir kod

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

Altın Üye
Katılım
13 Kasım 2009
Mesajlar
337
Excel Vers. ve Dili
Ofis 2016 TR 64 Bit
Sayın halit3 çok teşekkür ederim. Dosyayı seçimlik değilde sabit bir dosya yapabilirmisiniz?
 

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,758
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
KOD

Rich (BB code):
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

Altın Üye
Katılım
13 Kasım 2009
Mesajlar
337
Excel Vers. ve Dili
Ofis 2016 TR 64 Bit
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

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,758
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
kod

Rich (BB code):
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
 

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,758
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Teşekkürler iyi çalışmalar
 
Katılım
7 Ağustos 2019
Mesajlar
2
Excel Vers. ve Dili
2013
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.
 
Üst