Excel Forum

Excel Forum (http://www.excel.web.tr/index.php)
-   Beyin Fırtınası (http://www.excel.web.tr/forumdisplay.php?f=142)
-   -   "Alt Klasörleri" ve "Alt Klasörlerdeki Tüm Dosyaları" Listeleme (http://www.excel.web.tr/showthread.php?t=101323)

leumruk 10-06-2011 11:47

"Alt Klasörleri" ve "Alt Klasörlerdeki Tüm Dosyaları" Listeleme
 
1 Eklenti(ler)
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

Kod:

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-07-2011 12:45

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-07-2011 18:33

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-07-2011 22:22

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-07-2011 11:42

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

ugursirin 23-08-2011 14:58

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-08-2011 16:48

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

teşekkürler

halit3 27-08-2011 18:11

Alıntı:

keremd tarafından gönderildi (Mesaj 565870)
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-08-2011 18:16

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-09-2011 14:21

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


Saat 03:08

Powered by vBulletin Version 3.7.2
Copyright ©2000 - 2017, Jelsoft Enterprises Ltd.