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

leumruk · 10 Haziran 2011

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.

Kod:

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

Rich (BB code):

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

Darkion · 15 Temmuz 2011

teşekkürler elinize sağlık.

VB konusunda fazla bir bilgim olmadığı için eğer kusuruma bakmazsanız bir soru sormak istiyorum. Dosyaları hangi klasör/alt klasör içinde olduğunu gösterecek şekilde bu kodları geliştirmek mümkün müdür?

örn.:
C:\deneme\örnek1.xls
C:\deneme\deneme2\örnek2.xls
C:\deneme\deneme2\örnek3.pdf

Saygılar

leumruk · 16 Temmuz 2011

Merhaba,
İlgili kodda

Kod:

Cells(Say, 1) = dosya

bu satır yerine:

Kod:

Cells(Say, 1) = yol & "\" & dosya

yazarsanız istediğiniz olacaktır. İlk mesajımdaki kodlara da gerekli açıklamayı yaptım. Kodlardaki yeşil renkle belirttiğim açıklmayı uygulayabilirsiniz.

halit3 · 16 Temmuz 2011

Alternatif olarak da bende bir kod ekliyorum.

Burası klasörleri (altklasör dahil) listeliyor.

Kod:

Sub Klasör_Listele()
Columns("A:A").ClearContents
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
Liste1 (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 Liste1(Yol As String)
Dim fL As Object, f As Object, Dosya As String, j As Long
Set fL = CreateObject("Scripting.FileSystemObject").GetFolder(Yol).subfolders
j = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A1:A" & Rows.Count)) + 1
Cells(j, 1) = Yol
On Error GoTo sonraki
For Each f In fL
On Error Resume Next
Liste1 (f.Path)
sonraki:
Next
Set fL = Nothing
End Sub

Burası dosyaları (altklasör dahil) listeliyor

Kod:

Sub Dosya_Listele()
Columns("A:A").ClearContents
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
Liste2 (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 Liste2(Yol As String)
Dim fL As Object, f As Object, Dosya As String, j As Long
Set fL = CreateObject("Scripting.FileSystemObject").GetFolder(Yol).subfolders
Dosya = Dir(Yol & "\*.*")
While Dosya <> ""
DoEvents
j = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A1:A" & Rows.Count)) + 1
ekle = ""
If Right(Yol, 1) <> "\" Then ekle = "\"
Cells(j, 1) = Yol & ekle & Dosya
Dosya = Dir
Wend
On Error GoTo sonraki
For Each f In fL
On Error Resume Next
Liste2 (f.Path)
sonraki:
Next
Set fL = Nothing
End Sub

Darkion · 20 Temmuz 2011

İlginiz ve cevaplarınız için teşekkür ederim.

ugursirin · 23 Ağustos 2011

Sunucu uygulamaları. PHP ve ASP

Peki ben bu konu hakkında birşey sormak istiyorum. Sunucu üzerinde çalışan bir uygulama var mı?

keremd · 27 Ağustos 2011

Peki sadece alt klasörlerdeki dosyaları nasıl listeleriz?

teşekkürler

halit3 · 27 Ağustos 2011

keremd' Alıntı:
Peki sadece alt klasörlerdeki dosyaları nasıl listeleriz?

teşekkürler

Alt klasördeki dosyalar

Kod:

Sub Dosya_Listele()
Columns("A:A").ClearContents
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
Liste2 (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 Liste2(Yol As String)
Dim fL As Object, f As Object, Dosya As String, j As Long
Set fL = CreateObject("Scripting.FileSystemObject").GetFolder(Yol).SubFolders
On Error GoTo sonraki
For Each f In fL
Dosya = Dir(f.Path & "\*.*")
While Dosya <> ""
DoEvents
j = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A1:A" & Rows.Count)) + 1
ekle = ""
If Right(Yol, 1) <> "\" Then ekle = "\"
Cells(j, 1) = Yol & ekle & Dosya
Dosya = Dir
Wend
Liste2 (f.Path)
sonraki:
Next
Set fL = Nothing
End Sub

halit3 · 27 Ağustos 2011

Sadece klasör

Kod:

Sub Dosya_Listele()
Columns("A:A").ClearContents
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Yol = Klasor.SELF.Path
If InStr(1, Yol, "{") > 0 Then GoTo Atla
Dim fL As Object, Dosya As String, j As Long
Set fL = CreateObject("Scripting.FileSystemObject").GetFolder(Yol).SubFolders
Dosya = Dir(Yol & "\*.*")
While Dosya <> ""
DoEvents
j = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A1:A" & Rows.Count)) + 1
ekle = ""
If Right(Yol, 1) <> "\" Then ekle = "\"
Cells(j, 1) = Yol & ekle & Dosya
Dosya = Dir
Wend
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

tuncay_p · 24 Eylül 2011

Emeğinize sağlık çok güzel bir çalışma olmuş

bezl · 16 Aralık 2011

Merhaba bir klasör içindeki dosyaları ve sadece o klasörün içindeki klasörleri listeletebilir miyiz. Buradaki çalışmalardan yola çıkarak yapmaya çalıştım ama olmadı. Yardımcı olursanız sevinirim.

halit3 · 16 Aralık 2011

bezl' Alıntı:
Merhaba bir klasör içindeki dosyaları ve sadece o klasörün içindeki klasörleri listeletebilir miyiz. Buradaki çalışmalardan yola çıkarak yapmaya çalıştım ama olmadı. Yardımcı olursanız sevinirim.

9 nolu mesajdaki kod sadece klasörün içindeki dosyaları listaliyor.

4 nolu mesejdaki kodun aşağıdaki bölümünü silip denermisiniz.

Kod:

On Error GoTo sonraki
For Each f In fL
On Error Resume Next
Liste1 (f.Path)
sonraki:
Next

Kod:

On Error GoTo sonraki
For Each f In fL
On Error Resume Next
Liste2 (f.Path)
sonraki:
Next

bezl · 16 Aralık 2011

Dediklerinizi yaptım. Bir klasör içindeki sadece dosyaları alabiyorum zaten. Ama buna bir klasör içindeki sadece altklasörleri olmadan klasörleri nasıl ekleyeceğim.

halit3 · 16 Aralık 2011

bezl' Alıntı:
Dediklerinizi yaptım. Bir klasör içindeki sadece dosyaları alabiyorum zaten. Ama buna bir klasör içindeki sadece altklasörleri olmadan klasörleri nasıl ekleyeceğim.

Yukarıdaki mesajımda anlatmaya çalışmıştım kodun kırmızı bölümünü silip denermisiniz.

Kod:

Columns("A:A").ClearContents
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
Liste2 (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 Liste2(Yol As String)
Dim fL As Object, f As Object, Dosya As String, j As Long
Set fL = CreateObject("Scripting.FileSystemObject").GetFolder(Yol).subfolders
Dosya = Dir(Yol & "\*.*")
While Dosya <> ""
DoEvents
j = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A1:A" & Rows.Count)) + 1
ekle = ""
If Right(Yol, 1) <> "\" Then ekle = "\"
Cells(j, 1) = Yol & ekle & Dosya
Dosya = Dir
Wend
[COLOR=red]On Error GoTo sonraki[/COLOR]
[COLOR=red]For Each f In fL[/COLOR]
[COLOR=red]On Error Resume Next[/COLOR]
[COLOR=red]Liste2 (f.Path)[/COLOR]
[COLOR=red]sonraki:[/COLOR]
[COLOR=red]Next[/COLOR]
Set fL = Nothing
End Sub

bezl · 16 Aralık 2011

Bunu yaptığınızda sadece o klasör içindeki dosyayı gösteriyor. Bu klasörde 3 tane daha klasör var diyelim. Bunların alt klasörleri olmadan sadece bu 3 klasör adı gelsin istiyorum.

halit3 · 16 Aralık 2011

bezl' Alıntı:
Bunu yaptığınızda sadece o klasör içindeki dosyayı gösteriyor. Bu klasörde 3 tane daha klasör var diyelim. Bunların alt klasörleri olmadan sadece bu 3 klasör adı gelsin istiyorum.

Bunu denermisiniz.

Kod:

Sub Klasör_Listele()
Columns("A:A").ClearContents
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
Liste1 (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 Liste1(Yol As String)
Dim j As Long
ekle = ""
If Right(Yol, 1) <> "\" Then ekle = "\"
For Each Klasor In CreateObject("Scripting.FileSystemObject").GetFolder(Yol).subfolders
j = [a65000].End(3).Row + 1
Cells(j, 1) = Yol & ekle & Klasor.Name
Next
End Sub

halit3 · 16 Aralık 2011

Buda farklı kod

Kod:

Sub Klasör_Listele()
Columns("A:A").ClearContents
Set Yol = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Yol Is Nothing Then
Kaynak = Yol.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
If Right(Kaynak, 1) <> "\" Then Kaynak= Kaynak & "\"
End If
For Each Klasor In CreateObject("Scripting.FileSystemObject").GetFolder(Kaynak).subfolders
j = [a65000].End(3).Row + 1
Cells(j, 1) = Kaynak & Klasor.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

Bogachank · 16 Aralık 2011

Merhaba,

Alternatif olarak daha önce Haluk, Hamitcan ve Korhan üstatların yardımları ile derlediğim çalışmayı ekte bilgilerinize sunarım.

Bu vesile ile hocalarımıza tekrar teşekkür ederim.

Saygılarımla.

http://www.excel.web.tr/f48/active-directory-de-ki-kullanycy-ad-soyady-yazdyrma-t103523/sayfa3.html

Çalışma 1; Aşağıdaki kod seçilen klasördeki dosyaların dosya adlarını, linklerini ve çeşitli özelliklerini sıralamaktadır.

Kod:

Public ui As Long
Sub SubHsr()
Dim soru As String
10  If Application.Workbooks.Count = 0 Then
11      soru = "Açık Çalışma Kitabı bulunmamaktadır, yeni çalışma kitabı açılsın mı?"
12      If MsgBox(soru, vbYesNo) = vbYes Then
13          Workbooks.Add: GoTo 18
14      Else
15          MsgBox "Açık çalışma kitabı olmadığından çıklacaktır": GoTo 117
16      End If
17  Else
18      soru = ActiveWorkbook.Name & " kitabının " & ActiveSheet.Name
19      soru = soru & " sayfasına Dosyalar listelenecektir." & vbLf & "Devam Etmek İstiyormusunuz?"
20      If MsgBox(soru, vbYesNo) = vbYes Then
21          GoTo 101
22      Else
23          GoTo 117
24      End If
25  End If
101    Dim klsrSec As Object
102    Dim klsrMsUstu, Dosya, yol As String
103    Set klsrSec = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasor seçin !", 1)
104    klsrMsUstu = CreateObject("WScript.Shell").SpecialFolders("Desktop")
105        If klsrSec Is Nothing Then GoTo 117
106        If klsrSec = "Masaüstü" Or Klasor = "Desktop" Then
107            yol = klsrMsUstu
108            AnaListe (yol)
109            AltListe (yol)
110        ElseIf klsrSec <> "Masaüstü" Then
111            yol = klsrSec.Items.Item.Path
112            AnaListe (yol)
113            AltListe (yol)
114        Else
115            GoTo 117
116        End If
117    Set klsrSec = Nothing: ui = 0
End Sub
Private Sub AnaListe(yol As String)
201 Dim Dosya As String
202 Cells.ClearContents
203 Range("A4") = "Dosya Yolu":             Range("B4") = "Dosya Adı"
204 Range("C4") = "Dosya Tipi":             Range("D4") = "Dosya Boyutu"
205 Range("E4") = "Oluşturulma Tarihi":     Range("F4") = "Son Erişim Tarihi"
206 Range("G4") = "Son Düzenleme Tarihi":   Range("H4") = "Son Düzenleme Zamanı"
207 Dosya = Dir(yol & "\*.*")
208 ui = 4
209 While Dosya <> ""
210     DoEvents
211     ui = ui + 1
212     Cells(ui, 1) = yol
213     Cells(ui, 2) = Dosya
214     Call DosyaOzellikleri(yol & Application.PathSeparator & Dosya)
215     Dosya = Dir
216 Wend
End Sub
Private Sub AltListe(yol As String)
On Error Resume Next
301 Dim klsrAra, klsrLst As Object, Dosya, dsyTYl As String
302 Set klsrLst = CreateObject("Scripting.FileSystemObject").GetFolder(yol).SubFolders
303 On Error GoTo 316
304 For Each klsrAra In klsrLst
305     Dosya = Dir(klsrAra.Path & "\*.*")
306     While Dosya <> ""
307        DoEvents
308        ui = [a65000].End(3).Row + 1
309        Cells(ui, 1) = klsrAra.Path & "\"
310        Cells(ui, 2) = Dosya
311        Call DosyaOzellikleri(klsrAra.Path & Application.PathSeparator & Dosya)
312        Dosya = Dir
313     Wend
314     AltListe (klsrAra.Path)
315 Next
316 Set klsrAra = Nothing: Set klsrLst = Nothing
End Sub
Private Sub DosyaOzellikleri(dsyBak As String)
401 Dim DsSisKnt, Dosyam As Object
402 Set DsSisKnt = CreateObject("Scripting.FileSystemObject")
403 Set Dosyam = DsSisKnt.GetFile(dsyBak)
404 With Dosyam
405    ActiveSheet.Hyperlinks.Add Anchor:=Range("B" & ui), Address:=dsyBak
406    Range("C" & ui) = .Type
407    Range("D" & ui) = Format(.Size / 1024, "#,##0.0000") & " Kb"
408    Range("E" & ui) = Format(.DateCreated, "dd.mm.yyyy")
409    Range("F" & ui) = Format(.DateLastAccessed, "dd.mm.yyyy")
410    Range("G" & ui) = Format(.DateLastModified, "dd.mm.yyyy")
411    Range("H" & ui) = Format(.DateLastModified, "hh:mm:ss")
412 End With
413 Set DsSisKnt = Nothing
414 Set Dosyam = Nothing
End Sub

Çalışma 2; Bu kodda ise seçilen yerdeki dosyaların yolunu manuel yazmakla beraber devamında gelen ekranda istediğimiz uzantı tipini ( *.* ; *.xls ; *.doc ; vs... ) şeklinde yazarak arama için uzantı kıstası oluşturabilmekteyiz.

Kod:

Sub Listele()
Dim DTipi$, Klasor$
Klasor = InputBox(" ÖNEMLİ ! : Bulunan değerleri seçili hücreden aşağı doğru yapacağından, doğru sayfa ve doğru hücreyi seçtiğinizden emin olun. Eğer emin değilseniz Cancele basıp çıkın eminseniz, Aşağıya veri girebilirsiniz. " & Chr(13) & "     " & Chr(13) & "Listelenecek yolu yazınız." & Chr(13) & " " & Chr(13) & " Örneğin " & Chr(13) & " D:  " & Chr(13) & "   veya   " & Chr(13) & " C:\Documents and Settings\mozdem\Desktop  ", "Aranacak Dosyaların Yolu ? ")
If Klasor = "" Then End
DTipi = InputBox("Listelenecek dosya türünü yazınız", "Dosya türü ne?", "*.*")
Call ListeAl(Klasor, DTipi, True)
End
End Sub
Sub ListeAl(Klasor$, DTipi$, Alt%)
Dim klasorler(), i, Dosya$, yol$, attr%, ks%
Static r
On Error Resume Next
If Right$(Klasor, 1) <> "\" Then Klasor = Klasor & "\"
If DTipi = "" Then End
Dosya = Dir(Klasor & DTipi, vbNormal)
Do While Dosya <> ""
        yol = Klasor & Dosya
        ActiveCell.Offset(r, 0) = yol
        r = r + 1
        Dosya = Dir()
Loop
If Alt = False Then Exit Sub
Dosya = Dir(Klasor & "*.*", vbDirectory)
Do While Dosya <> ""
    attr = 0
    attr = GetAttr(Klasor & Dosya)
    If Dosya <> "." And Dosya <> ".." And _
        (attr And vbDirectory) <> 0 _
    Then
        ks = ks + 1 'klasör sayısı
        ReDim Preserve klasorler(1 To ks)
        klasorler(ks) = Dosya
    End If
    Dosya = Dir()
Loop

For i = 1 To ks
     Call ListeAl(Klasor & klasorler(i) & "\", DTipi, Alt)
Next i
End Sub

bezl · 16 Aralık 2011

Çok özür dileyerek seçtiğim klasörün altındaki klasörlerini (bu klasörlerin alt klasörleri hariç) nasıl listeletirim diye yine sormak istiyorum. Verilen cevaplar bütün alt klasörleri listelemek var.

halit3 · 17 Aralık 2011

bezl' Alıntı:
Çok özür dileyerek seçtiğim klasörün altındaki klasörlerini (bu klasörlerin alt klasörleri hariç) nasıl listeletirim diye yine sormak istiyorum. Verilen cevaplar bütün alt klasörleri listelemek var.

17 nolu mesajdaki kodu denedinizmi?

Yeni bir dosya oluşturun bu kodu bir modül içine koyup deneyin ve denediğiniz dosyayı buraya ekleyin bir bakalım.

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

leumruk

Uzman

Ekli dosyalar

Darkion

leumruk

Uzman

halit3

Uzman

Darkion

ugursirin

keremd

halit3

Uzman

halit3

Uzman

tuncay_p

bezl

halit3

Uzman

bezl

halit3

Uzman

bezl

halit3

Uzman

halit3

Uzman

Bogachank

Ekli dosyalar

bezl

halit3

Uzman