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

[leumruk]

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

[Darkion]

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]

Merhaba,
İlgili kodda Cells(Say, 1) = dosya bu satır yerine: 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]

Alternatif olarak da bende bir kod ekliyorum.

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

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.Na me).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

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.Na me).Range("A1:A" & Rows.Count)) + 1
If Right(Yol, 1) = "\" Then
ekle = Yol
Else
ekle = Yol & "\"
End If
Cells(j, 1) = 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]

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

[ugursirin]

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

[keremd]

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

teşekkürler

[halit3]

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

teşekkürler

Alt klasördeki dosyalar

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.Na me).Range("A1:A" & Rows.Count)) + 1
If Right(Yol, 1) = "\" Then
ekle = Yol
Else
ekle = Yol & "\"
End If
Cells(j, 1) = ekle & Dosya
Dosya = Dir
Wend
Liste2 (f.Path)
sonraki:
Next
Set fL = Nothing
End Sub

[halit3]

Sadece klasör

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.Na me).Range("A1:A" & Rows.Count)) + 1
If Right(Yol, 1) = "\" Then
ekle = Yol
Else
ekle = Yol & "\"
End If
Cells(j, 1) = 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]

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

[bezl]

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]

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.

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


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

[bezl]

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]

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.

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.Na me).Range("A1:A" & Rows.Count)) + 1
If Right(Yol, 1) = "\" Then
ekle = Yol
Else
ekle = Yol & "\"
End If
Cells(j, 1) = 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

[bezl]

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]

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.

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
If Right(Yol, 1) = "\" Then
ekle = Yol
Else
ekle = Yol & "\"
End If
For Each Klasor In CreateObject("Scripting.FileSystemObject").GetFolder(Yol).subfolders
j = [a65000].End(3).Row + 1
Cells(j, 1) = ekle & Klasor.Name
Next
End Sub

[halit3]

Buda farklı 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
ekle = Kaynak
Else
ekle = Kaynak & "\"
End If
For Each Klasor In CreateObject("Scripting.FileSystemObject").GetFolder(Kaynak).subfolders
j = [a65000].End(3).Row + 1
Cells(j, 1) = ekle & 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]

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.

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.

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]

Ç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]

Ç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.

[bezl]

Çok teşekkür ederim olmuş.

[halit3]

Çok teşekkür ederim olmuş.

İyi çalışmalar

[levoni]

Ellerinize aklınıza kollarınıza sağlık çok faydalı çalışmalar olmuş.Tamda böyle bir çalışmaya ihtiyacım vardı.

Teşekkürler eksik olmayın