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

[halit3]

Kodu birazcık daha kısalttım

Dim dosya

Sub deneme()

Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Klasörü Seçin", 50, &H0)
If Klasor Is Nothing Then Exit Sub
Kaynak = Klasor.self.Path
Columns("A:B").ClearContents
Cells(1, 1) = "İSİMLER": Cells(1, 2) = "ŞEHİRLER"
For Each f In CreateObject("Scripting.FileSystemObject").GetFolder(Kaynak).subfolders
dosya = f.Name: Liste (Kaynak & "\" & f.Name)
Next
MsgBox "işlem tamam"

End Sub

Private Sub Liste(yol As String)

Dim fL As Object, f As Object, j As Long
Set fL = CreateObject("Scripting.FileSystemObject")
On Error GoTo sonraki
For Each f In fL.GetFolder(yol).subfolders
j = WorksheetFunction.CountA(Range("A1:A" & Rows.Count)) + 1
Cells(j, 1) = dosya: Cells(j, 2) = f.Name
On Error Resume Next
Liste (f.Path)
sonraki:
Next
Set fL = Nothing

End Sub

 

[TURKOLOG]

Sayın Halit Hocam affınıza sığınarak kodu kendime revize etmeye çalıştım ama olmadı
yapacağım işlemi alt klasörler dahil seçilen klasör ve altındaki klasörlere uygulamaya çalıştım ama olmadı
Ekli listede belirtiğim dosyada Açılmasını istediğim dosya ve klasörler için bir sabit yol zorunlu textboxa giriliyor . Her kaydet değidinde SABİTLER sayfasının B5 yoluna kaydedilecek şekilde
İsteğe bağlı 5 yolda yine SABİTLER sayfasının B6-10 aralığına kaydedilecek ama isteğe bağlı dosya ve klasör arama yolu dolu olmak zorunda değil

Klasör için mi Dosya için mi yoksa hem klasör hem dosya için mi arama yapılacağı seçildikten sonra Listele denince tercih neyse ona göre Listbox 1 ve ya 2 ye veya Listbox1-2 ye veri gelecek klasörse tıklayınca klasör açılacak dosya ise tıklayıca dosya türü ne ise o türden açılacak

Comcobox3 ve Combobox2 den de açılır menu şeklinde yol bulunabilecek

Textbox8 ve9 ile de Listbox1 ve 2 deki veri fazla olursa süzmeyi hedefliyorum ama işin içinden çıkamadım yardım ederseniz çok sevinirim.
Dosya Yolu

 

[halit3]

Sayın Halit Hocam affınıza sığınarak kodu kendime revize etmeye çalıştım ama olmadı
yapacağım işlemi alt klasörler dahil seçilen klasör ve altındaki klasörlere uygulamaya çalıştım ama olmadı
Ekli listede belirtiğim dosyada Açılmasını istediğim dosya ve klasörler için bir sabit yol zorunlu textboxa giriliyor . Her kaydet değidinde SABİTLER sayfasının B5 yoluna kaydedilecek şekilde
İsteğe bağlı 5 yolda yine SABİTLER sayfasının B6-10 aralığına kaydedilecek ama isteğe bağlı dosya ve klasör arama yolu dolu olmak zorunda değil

Klasör için mi Dosya için mi yoksa hem klasör hem dosya için mi arama yapılacağı seçildikten sonra Listele denince tercih neyse ona göre Listbox 1 ve ya 2 ye veya Listbox1-2 ye veri gelecek klasörse tıklayınca klasör açılacak dosya ise tıklayıca dosya türü ne ise o türden açılacak

Comcobox3 ve Combobox2 den de açılır menu şeklinde yol bulunabilecek

Textbox8 ve9 ile de Listbox1 ve 2 deki veri fazla olursa süzmeyi hedefliyorum ama işin içinden çıkamadım yardım ederseniz çok sevinirim.
Dosya Yolu

Sayın TURKOLOG bu konu başlığı klasörleri ve dosyaları listelemek sizin sorunuz bu konu ile uyumlu değil farklı bir konu başlığı altında sorunuzu sorun.

 

[muyat]

Halit hocam tekrar merhaba....Verdiginiz kodlar çalışıyor ama problem şu:
Ben Mehmete ait Alt klasörleri silince Listede Mehmet'in ismi çıkmıyor.Listede mehmetin adı da çıkcak ve ona ait alt klasör yoksa şehirler yazan sütundaki mehmete karşılık gelen satırın içi boş kalcak....Böylece Mehmete alt klasör verilmedigini anlıcaz.Bu dedigim şey bütün isimler için geçerli.Önceki arkadaşın yazdıgı kodlarda da bu problem var.
Bu arada şöyle bi değişiklik yaptık projede
Görevliler isimli bir klasörde, çalışan kişilerin isimlerinin oldugu alt klasörler var ve isimlere ait alt klasörlerin her birinin içine, hergün bir alt klasör ekleniyor..Bu eklenen alt klasörlere de isim olarak eklendiği günün tarihi yazılıyor.Örnegin 05.04.2020 .Ve bu her gün eklenen tarih isminin yazılı oldugu alt klasörlerin içinde de işyeri isimleri olan alt klasörler var..Onların içinde de dosyalar ve evraklar var....Mesela yarın bana 06.04.2020 isimli bir klasör eklenecek.İçinde işyerlerine ait kaç alt klasör var bilmiyorum..
Ama makro çalışınca mesela bir başkasına, yarın 06.04.2020 isimli klasör eklenmezse o sütuna karşılık gelen ilgili kişiye ait satırdaki hücre boş kalcak..Örnegin aşagıdaki Ahmet isimli kişiye yarın klasör gönderilmeyecek.
Ve bu ekleme durumunun ne zaman bitecegi belli değil.1 ay da sürebilir, 1 yıl da...Ülkemizin içinde bulundugu duruma baglı. O nedenle sütun sayısında sınırlama olmamalı...
Bu problem yüzünden bazı işyerlerinin dağılımı,farklı tarihlerde birden fazla isime gidiyor anlaşılması zor oluyor....Gereksiz yere toner ve kagıt israfı oldugu gibi zaman kaybı oluyor...Böylece mükerrer olanları bulmaya çalışacagız
Yani bir örnek vercek olursam makro çalışınca aşagıdaki gibi olmalı.Mesela Ali isimli arkadaşa ayın 7sinde 0 7.04.2020 isimli bir alt klasör gönderilecek ve içinde RR Ve SS firması alt klasör var ve gruba o zaman dahil oluyor..Selami Bey'e 06.04.2020 tarihinde 06.04.2020 isimli alt klasör gönderilmemiş o nedenle ordaki hücre boş kalmış.07.04.2020 isimli hücrenin sağında bulunan hücrenin 08.04.2020 ismini alabilmesi için o isimdeki öyle bir klasörün listedeki isimlerden en az bir kişiye verilmiş olması gerekli. Ve yine 08.04.2020 tarihli klasörden Ahmete de verilirse ve içinde 10 firma adı varsa isimler yazan sütunda yukardan aşagıya 10 tane "Ahmet" yazması gerekir. 1 .satırdaki İSİMLER isimli hücre hariç diğer hücreler adlarını, isimlere eklenen alt klasörden alcak.Veya elle de yazarız.Sorun değil.Henüz makro yazmayı yeni yeni ögrendigim için problem beni aşıyor..Yardımlarınızı rica ediyorum

 

[halit3]

Halit hocam tekrar merhaba....Verdiginiz kodlar çalışıyor ama problem şu:
Ben Mehmete ait Alt klasörleri silince Listede Mehmet'in ismi çıkmıyor.Listede mehmetin adı da çıkcak ve ona ait alt klasör yoksa şehirler yazan sütundaki mehmete karşılık gelen satırın içi boş kalcak....Böylece Mehmete alt klasör verilmedigini anlıcaz.Bu dedigim şey bütün isimler için geçerli.Önceki arkadaşın yazdıgı kodlarda da bu problem var.
Bu arada şöyle bi değişiklik yaptık projede
Görevliler isimli bir klasörde, çalışan kişilerin isimlerinin oldugu alt klasörler var ve isimlere ait alt klasörlerin her birinin içine, hergün bir alt klasör ekleniyor..Bu eklenen alt klasörlere de isim olarak eklendiği günün tarihi yazılıyor.Örnegin 05.04.2020 .Ve bu her gün eklenen tarih isminin yazılı oldugu alt klasörlerin içinde de işyeri isimleri olan alt klasörler var..Onların içinde de dosyalar ve evraklar var....Mesela yarın bana 06.04.2020 isimli bir klasör eklenecek.İçinde işyerlerine ait kaç alt klasör var bilmiyorum..
Ama makro çalışınca mesela bir başkasına, yarın 06.04.2020 isimli klasör eklenmezse o sütuna karşılık gelen ilgili kişiye ait satırdaki hücre boş kalcak..Örnegin aşagıdaki Ahmet isimli kişiye yarın klasör gönderilmeyecek.
Ve bu ekleme durumunun ne zaman bitecegi belli değil.1 ay da sürebilir, 1 yıl da...Ülkemizin içinde bulundugu duruma baglı. O nedenle sütun sayısında sınırlama olmamalı...
Bu problem yüzünden bazı işyerlerinin dağılımı,farklı tarihlerde birden fazla isime gidiyor anlaşılması zor oluyor....Gereksiz yere toner ve kagıt israfı oldugu gibi zaman kaybı oluyor...Böylece mükerrer olanları bulmaya çalışacagız
Yani bir örnek vercek olursam makro çalışınca aşagıdaki gibi olmalı.Mesela Ali isimli arkadaşa ayın 7sinde 0 7.04.2020 isimli bir alt klasör gönderilecek ve içinde RR Ve SS firması alt klasör var ve gruba o zaman dahil oluyor..Selami Bey'e 06.04.2020 tarihinde 06.04.2020 isimli alt klasör gönderilmemiş o nedenle ordaki hücre boş kalmış.07.04.2020 isimli hücrenin sağında bulunan hücrenin 08.04.2020 ismini alabilmesi için o isimdeki öyle bir klasörün listedeki isimlerden en az bir kişiye verilmiş olması gerekli. Ve yine 08.04.2020 tarihli klasörden Ahmete de verilirse ve içinde 10 firma adı varsa isimler yazan sütunda yukardan aşagıya 10 tane "Ahmet" yazması gerekir. 1 .satırdaki İSİMLER isimli hücre hariç diğer hücreler adlarını, isimlere eklenen alt klasörden alcak.Veya elle de yazarız.Sorun değil.Henüz makro yazmayı yeni yeni ögrendigim için problem beni aşıyor..Yardımlarınızı rica ediyorum

Sayın muyat konu bütünlüğü bozulmaması için sorunuzu farklı bir konu başlığı altında yeni soru sorarak sorun bu konu başlığı klasör ve dosyaları listelemek sizin sorunuz bu duruma uymuyor.

 

[konas06]

Bu kodu bir dene

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

Hocam bu konu ile çok uğraşmışsınız belli ki, Ancak bu kodlamaya bir de köprüleme ekleyebilir miyiz?
Şimdiden teşekkür ederim.

 

[halit3]

Hocam bu konu ile çok uğraşmışsınız belli ki, Ancak bu kodlamaya bir de köprüleme ekleyebilir miyiz?
Şimdiden teşekkür ederim.

Bu kod bir dene

Dim dosya
Dim dosya2

Sub deneme()

Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Klasörü Seçin", 50, &H0)
If Klasor Is Nothing Then Exit Sub
Kaynak = Klasor.self.Path
Columns("A:B").ClearContents

Columns("A:B").Cells.Hyperlinks.Delete
Columns("A:B").Cells.Font.ColorIndex = 0

Cells(1, 1) = "İSİMLER": Cells(1, 2) = "ŞEHİRLER"
For Each f In CreateObject("Scripting.FileSystemObject").GetFolder(Kaynak).subfolders
dosya2 = f.Path
dosya = f.Name: Liste (Kaynak & "\" & f.Name)
Next
MsgBox "işlem tamam"

End Sub

Private Sub Liste(yol As String)

Dim fL As Object, f As Object, j As Long
Set fL = CreateObject("Scripting.FileSystemObject")
On Error GoTo sonraki
For Each f In fL.GetFolder(yol).subfolders
j = WorksheetFunction.CountA(Range("A1:A" & Rows.Count)) + 1
'Cells(j, 1) = dosya
Cells(j, 1).Hyperlinks.Add Anchor:=Cells(j, 1), Address:=dosya2, SubAddress:="" & firstAddress, TextToDisplay:=dosya  'fL.GetBaseName(Dir(Dosya))
'Cells(j, 2) = f.Name
Cells(j, 2).Hyperlinks.Add Anchor:=Cells(j, 2), Address:=f.Path, SubAddress:="" & firstAddress, TextToDisplay:=f.Name   'fL.GetBaseName(Dir(Dosya))
On Error Resume Next
Liste (f.Path)
sonraki:
Next
Set fL = Nothing

End Sub

 

[halit3]

Hocam bu konu ile çok uğraşmışsınız belli ki, Ancak bu kodlamaya bir de köprüleme ekleyebilir miyiz?
Şimdiden teşekkür ederim.

Bu kodu bir dene

 

[Theyakops]

Halit hocam ellerinize emeğinize sağlık konudaki tüm kodlarınızı tek tek denedim. Fakat ihtiyacım olanı tam bulamadım.
Benim talebim tam olarak şu şekilde; seçtiğim ana klasörden başlayarak içerisindeki; hem tüm alt klasörleri + hemde dosyaları listelemek istiyorum. İç içe hiç alt klasör ve dosya kalmayana dek tümünü listelemek.

Ve mümkünse windows kayıt defteri düzenleyicisinin dizin ağacında olduğu gibi; dosya + klasör isimleri yazılırken; alt dizindeki isimlerin her seferinde sağdaki bir alt hücreye yazılmasını istiyorum. (Eklediğim örnek resimdeki gibi, tabi mümkünse)

 

[halit3]

kod:

Dim sayi
Dim sat

Sub klasör_dosya()
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Klasörü Seçin", 50, &H0)
If Klasor Is Nothing Then Exit Sub
Kaynak = Klasor.self.Path
'Kaynak = ThisWorkbook.Path & "\deneme"
Cells.ClearContents
sat = 1
deg1 = Split(Kaynak, "\")
If UBound(deg1) > 0 Then
sayi = UBound(deg1)
End If
Liste (Kaynak)
MsgBox "işlem tamam"
End Sub
Private Sub Liste(yol As String)
Dim fL As Object, fs As Object, f As Object, j As Long, n As Long
Set fL = CreateObject("Scripting.FileSystemObject")

deg1 = Split(yol, "\")
If UBound(deg1) > 0 Then
sut = UBound(deg1) + 1 - sayi
End If

Cells(sat, sut) = fL.GetBaseName(yol) 'dosya.Name
sut = sut + 1
If fL.GetFolder(yol).Files.Count > 0 Then
For Each dosya In fL.GetFolder(yol).Files
sat = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
Cells(sat, sut) = fL.GetBaseName(dosya.Name)  'dosya.Name
Next
End If
sat = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
On Error GoTo sonraki
For Each f In fL.GetFolder(yol).subfolders
Liste (f.Path)
sonraki:
Next

End Sub

 

[aydogankemal]

Merhaba,
Excel 2003'te bulunan Filesearch ile alt klasörleri ve içlerinde bulunan dosyaları rahatlıkla listeleyebiliyorduk. Ancak 2007 ve 2010 sürümlerinde "Filesearch" kodunun çalışmamasından dolayı artık bu kod kullanışlı olma özelliğini yitirdi.

Bu nedenle Alt klasörleri ve alt klasörler içinde bulunan dosyaları listelemeye yarayan bir kod hazırladım. Ekteki Rarda bulunan klasörde örnek olması için alt klasörler ve içlerine rasgele dosyalar oluşturdum. Klasörü rardan çıkarıp deneme yapabilirsiniz. Umarım faydalı olur.

NOT: Kodlar alt klasörlerin içlerindeki tüm alt klasörleri ve bunların içinde bulunan tüm dosyaları listeler.

Sizinde konu hakkında alternatifleriniz varsa bu başlığa ekleyebilirsiniz.

Sub Dosya_Listele() 'Tüm alt klasörlerdeki dosyaları listeler
Set ds = CreateObject("Scripting.FileSystemObject")
yol = ThisWorkbook.Path
Columns(1).Clear
Application.ScreenUpdating = False
Do
Tekrar:
If ds.GetFolder(yol).subfolders.Count > 0 Then
    For Each kls In ds.GetFolder(yol).subfolders
        klslst = klslst & "{" & kls
    Next
End If
x = x + 1
deg = Split(klslst, "{")
yol = deg(x)
Dosya = Dir$(yol & "\*.*")
Do While Dosya <> ""
Say = Say + 1
Cells(Say, 1) = Dosya 'dosya yerine yol & "\" & dosya yazarsanız dosyalar yollarıyla birlikte listelenir.
Dosya = Dir$()
Loop
If x = 1 And ds.GetFolder(yol).subfolders.Count > 0 Then GoTo Tekrar
Loop While UBound(deg) <> x
'Kodlayan: l e u m r u k - mustafa altun
End Sub

Sub Klasör_Listele() 'Tüm alt klasörleri listeler
Set ds = CreateObject("Scripting.FileSystemObject")
yol = ThisWorkbook.Path
Columns(1).Clear
Application.ScreenUpdating = False
Do
Tekrar:
If ds.GetFolder(yol).subfolders.Count > 0 Then
    For Each kls In ds.GetFolder(yol).subfolders
        klslst = klslst & "{" & kls
    Next
End If
x = x + 1
deg = Split(klslst, "{")
yol = deg(x)
Cells(x, 1) = deg(x)
If x = 1 And ds.GetFolder(yol).subfolders.Count > 0 Then GoTo Tekrar
Loop While UBound(deg) <> x
'Kodlayan: l e u m r u k - mustafa altun
End Sub

Merhaba,
Kodlarınızla D klasörünü listelemek için aşağıdaki şekilde düzelttim, ama hata veriyor, nasıl bir düzeltme yapabilirim

Sub Klasör_Listele() 'Tüm alt klasörleri listeler
Set ds = CreateObject("Scripting.FileSystemObject")
yol = "D:\"
Columns(1).Clear
Application.ScreenUpdating = False
Do
Tekrar:
If ds.GetFolder(yol).subfolders.Count > 0 Then
For Each kls In ds.GetFolder(yol).subfolders
klslst = klslst & "{" & kls
Next
End If
x = x + 1
deg = Split(klslst, "{")
yol = deg(x)
Cells(x, 1) = deg(x)
If x = 1 And ds.GetFolder(yol).subfolders.Count > 0 Then GoTo Tekrar

Loop While UBound(deg) <> x

'Kodlayan: l e u m r u k - mustafa altun
End Sub