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

[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

 

[demondivx]

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.Name).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

Öncelikle kod işime çok yaradı çok teşekkür ederim. Sizden küçük bir isteğim olacak yukarıdaki kodda 2. sütun yani B sütununa mb cinsinden dosya boyutlarını getirebilmemiz mümkün olur mu? çok arattım ama bulamadım şimdiden çok teşekkür ederim. ayrıca o kod ile oluşturduğum xlsm dosyam ekte mevcuttur.

 

[halit3]

Öncelikle kod işime çok yaradı çok teşekkür ederim. Sizden küçük bir isteğim olacak yukarıdaki kodda 2. sütun yani B sütununa mb cinsinden dosya boyutlarını getirebilmemiz mümkün olur mu? çok arattım ama bulamadım şimdiden çok teşekkür ederim. ayrıca o kod ile oluşturduğum xlsm dosyam ekte mevcuttur.

Bunu denermisiniz.

Sub Dosya_Listele()
Columns("A:C").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
Dim ekle
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).Value = yol & ekle & Dosya
On Error Resume Next
With CreateObject("Scripting.FileSystemObject").GetFile(yol & ekle & Dosya)
Cells(j, 2).Value = Format(.Size / 1024, "#,##0.000") & " Kb"
Cells(j, 3).Value = Format(.Size, "#,###")
End With
Dosya = Dir
Wend
On Error GoTo sonraki
For Each f In fL
Liste2 (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub

 

[cigerkarakaya]

Dosyaların boyutlarının dışında bir de sayfa sayısını ekleyebilir miyiz?

 

[halit3]

Dosyaların boyutlarının dışında bir de sayfa sayısını ekleyebilir miyiz?

Konu bütünlüğü bozulmaması için farklı bir başlık altında yeni bir konu açarak sorunuzu örnek dosyanızıda ekliyerek sorunuz.

 

[Bora K]

Merhabalar Halit Hocam;

Aşağıdaki kod
Alt kalsörler dahil dosya isimlerini
A sütununa bu formatta listeliyor.
C:\Documents and Settings\......\Desktop\Arşiv\Dosya Adlarını Listeler.xls

Ben ise;

B sütununa "Arşiv" yazsın C sütununa ise "Dosya Adlarını Listeler" yazsın
şeklinde istiyorum.

Şayet mümkünatı var ise çok sevinirim.
Saygılarımla.

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

 

[halit3]

Merhabalar Halit Hocam;

Aşağıdaki kod
Alt kalsörler dahil dosya isimlerini
A sütununa bu formatta listeliyor.
C:\Documents and Settings\......\Desktop\Arşiv\Dosya Adlarını Listeler.xls

Ben ise;

B sütununa "Arşiv" yazsın C sütununa ise "Dosya Adlarını Listeler" yazsın
şeklinde istiyorum.

Şayet mümkünatı var ise çok sevinirim.
Saygılarımla.

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

kod:

Sub Dosya_Listele()
[COLOR="red"]Columns("B:C").ClearContents[/COLOR]
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("[COLOR="Red"]B[/COLOR]1:[COLOR="red"]B[/COLOR]" & Rows.Count)) + 1
ekle = ""
If Right(Yol, 1) <> "\" Then ekle = "\"
[COLOR="Red"]Cells(j, "b") = "Arşiv"
Cells(j, "c") = Yol & ekle & Dosya[/COLOR]
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

 

[arşivist1]

halit bey merhaba,

benim konuya da baksaydınız

 

[Bora K]

Halit Hocam emeğinize sağlık.
Çok teşekkür ediyorum.

 

[arachnanthe]

Merhaba arkadaşlar
18 nolu mesaj daki ekli dosyada ki dosya listeleme sekmesinde

* A sütünündaki dosya yollarınada B sütununda ki gibi link nasıl verilebilir
* alttaki resimde belirttiğim klasörler D:\ itibaren 4. sırada bu klasörlerin isimlerinide bir sütüna yazıp linkleyebilirmiyiz.
* ikinci resimdede dosya boyutlarını doğru göstermiyor bunuda düzeltebilirmiyiz

 

[yerbakili]

Merhaba,

CreateObject("shell.application").BrowseForFolder özelliği için varsayılan bir klasör atayabiliyor muyuz?

Yani bizden klasör seçmemiz istenilen ekran açıldığında, örn. "C:\deneme\açılacak_klasör" varsayılan olarak seçili gelmesini sağlayabilir miyiz?

 

[halit3]

Merhaba,

CreateObject("shell.application").BrowseForFolder özelliği için varsayılan bir klasör atayabiliyor muyuz?

Yani bizden klasör seçmemiz istenilen ekran açıldığında, örn. "C:\deneme\açılacak_klasör" varsayılan olarak seçili gelmesini sağlayabilir miyiz?

Bu konu başlığı altında farklı uygulamalar mevcut olduğundan siz hangi mesajdaki kodlara bu uygulamayı istiyorsunuz.

 

[yerbakili]

Bu konu başlığı altında farklı uygulamalar mevcut olduğundan siz hangi mesajdaki kodlara bu uygulamayı istiyorsunuz.

Bildiğim kadarıyla kullandığım kaynak kodlar bu konuda yer alan kodlardan değil. Kullandığım kodlar:

101    Dim klsrSec As Object
102    Dim klsrMsUstu, Dosya
103    Set klsrSec = CreateObject("Shell.Application").BrowseForFolder(0, "Resim Klasörünüzü Seçiniz !" & Chr(10) & _
"D:\Resimler", 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

Bu kodlarla, klasör seçme ekranının varsayılan olarak "D:\Resimler" klasöründen açılmasını sağlamak istiyorum. Mümkün müdür acaba?

 

[halit3]

Bildiğim kadarıyla kullandığım kaynak kodlar bu konuda yer alan kodlardan değil. Kullandığım kodlar:

101    Dim klsrSec As Object
102    Dim klsrMsUstu, Dosya
103    Set klsrSec = CreateObject("Shell.Application").BrowseForFolder(0, "Resim Klasörünüzü Seçiniz !" & Chr(10) & _
"D:\Resimler", 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

Bu kodlarla, klasör seçme ekranının varsayılan olarak "D:\Resimler" klasöründen açılmasını sağlamak istiyorum. Mümkün müdür acaba?

Bu kodun başı ve sonrası yok yazılan kod da bana ait değil alternatif olarak aşağıdaki kodu irdeleyin.

Dim msg1 As String

Sub dosyaListele()
msg1 = MsgBox("Alt klasör dahil edilsinmi.? ", vbYesNo + vbInformation, "u y a r ı !")
Kaynak = "[COLOR="Red"]D:\Resimler[/COLOR]"
Cells.ClearContents
Range("A1") = "Dosya Yolu"
Range("B1") = "Dosya Adı"
Range("C1") = "Dosya Tipi"
Range("D1") = "Dosya Boyutu"
Range("E1") = "Oluşturulma Tarihi"
Range("F1") = "Son Erişim Tarihi"
Range("G1") = "Son Düzenleme Tarihi"
Range("H1") = "Son Düzenleme Zamanı"
Liste1 (Kaynak)
MsgBox "işlem tamam !", vbInformation, "DİKKAT"

End Sub
Private Sub Liste1(yol As String)

Dim fs As Object, f As Object, j As Long
Set fs = CreateObject("Scripting.FileSystemObject")

For Each Dosya In fs.GetFolder(yol).Files
j = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A1:A" & Rows.Count)) + 1

Cells(j, 1) = Dosya
Cells(j, 2) = Dir(Dosya)

With fs.GetFile(Dosya)
ActiveSheet.Hyperlinks.Add Anchor:=Range("B" & j), Address:=Dosya
Range("C" & j) = .Type
Range("D" & j) = Format(.Size / 1024, "#,##0.0000") & " Kb"
Range("E" & j) = Format(.DateCreated, "dd.mm.yyyy")
Range("F" & j) = Format(.DateLastAccessed, "dd.mm.yyyy")
Range("G" & j) = Format(.DateLastModified, "dd.mm.yyyy")
Range("H" & j) = Format(.DateLastModified, "hh:mm:ss")
End With
Next


If msg1 = vbYes Then
On Error GoTo sonraki
For Each f In fs.GetFolder(yol).SubFolders
Liste1 (f.Path)
sonraki:
Next
End If

Set fL = Nothing

End Sub

 

[soneravci]

selamlar, konuyu başından itibaren takip ettim, sabrınızın sınandığını düşünmekle beraber, bende bir yerlerden dosya listeleme makrosu bulmuş ve yazmıştım fakat istediğim gibi sonuç vermedi. yazdığım makro;
sub dosyalarılistele ()

dim i as integer
columns(1).clear contents
chdir (cells(1,5))
dosya =dir("*.xlsx")
i=1
while dosya <> ""
cells(i,1) =dosya
dosya =dir
i=i+1
wend
end sub

kod sağlam fakat benim ihtiyaçlarım şu;
kodun çalışacağı dosyanın, içinde bulunduğu klasördeki, xlsx uzantılı dosyaları listelesin. yani her seferinde yeni bir yol girmek istemiyorum. çünkü klasörler hep değişken oluyor.
buna ek olarak bazen xlsx yanında xls leride eklesin istersem hangi kodu eklemeliyim

sonuç olarak bana dosya yolu nu vermese de olur tek istediğim
dosya 1
dosya 2
dosya 3
şeklinde sıralaması
iyi çalışmalar yardım için teşekkür ederim.

 

[halit3]

selamlar, konuyu başından itibaren takip ettim, sabrınızın sınandığını düşünmekle beraber, bende bir yerlerden dosya listeleme makrosu bulmuş ve yazmıştım fakat istediğim gibi sonuç vermedi. yazdığım makro;
sub dosyalarılistele ()

dim i as integer
columns(1).clear contents
chdir (cells(1,5))
dosya =dir("*.xlsx")
i=1
while dosya <> ""
cells(i,1) =dosya
dosya =dir
i=i+1
wend
end sub

kod sağlam fakat benim ihtiyaçlarım şu;
kodun çalışacağı dosyanın, içinde bulunduğu klasördeki, xlsx uzantılı dosyaları listelesin. yani her seferinde yeni bir yol girmek istemiyorum. çünkü klasörler hep değişken oluyor.
buna ek olarak bazen xlsx yanında xls leride eklesin istersem hangi kodu eklemeliyim

sonuç olarak bana dosya yolu nu vermese de olur tek istediğim
dosya 1
dosya 2
dosya 3
şeklinde sıralaması
iyi çalışmalar yardım için teşekkür ederim.

Sorunuzu sorarken alın yaparak sorarsanız iyi olur çünkü buradaki yazılı kodlar birden fazla kişiye ait

Alternatif olarak aşağıdaki kodu deneyiniz.

kod:

Dim msg1 As String

Sub dosyaListele()

msg1 = MsgBox("Alt klasör dahil edilsinmi.? ", vbYesNo + vbInformation, "u y a r ı !")
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
Range("A1") = "Dosya Yolu"
Range("B1") = "Dosya Adı"
Range("C1") = "Dosya Tipi"
Range("D1") = "Dosya Boyutu"
Range("E1") = "Oluşturulma Tarihi"
Range("F1") = "Son Erişim Tarihi"
Range("G1") = "Son Düzenleme Tarihi"
Range("H1") = "Son Düzenleme Zamanı"

Liste1 (Kaynak)
MsgBox "işlem tamam !", vbInformation, "DİKKAT"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
Set Obj = Nothing
Set Klasor = Nothing

End Sub





Private Sub Liste1(yol As String)

Dim fs As Object, f As Object, j As Long
Set fs = CreateObject("Scripting.FileSystemObject")

For Each Dosya In fs.GetFolder(yol).Files
Uzanti = fs.GetExtensionName(Dosya)
If Uzanti = [COLOR="Red"]"xls"[/COLOR] Or Uzanti = [COLOR="red"]"xlsx"[/COLOR] Then

j = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A1:A" & Rows.Count)) + 1

Cells(j, 1) = Dosya
Cells(j, 2) = Dir(Dosya)

With fs.GetFile(Dosya)
ActiveSheet.Hyperlinks.Add Anchor:=Range("B" & j), Address:=Dosya
Range("C" & j) = .Type
Range("D" & j) = Format(.Size / 1024, "#,##0.0000") & " Kb"
Range("E" & j) = Format(.DateCreated, "dd.mm.yyyy")
Range("F" & j) = Format(.DateLastAccessed, "dd.mm.yyyy")
Range("G" & j) = Format(.DateLastModified, "dd.mm.yyyy")
Range("H" & j) = Format(.DateLastModified, "hh:mm:ss")
End With
End If
Next

If msg1 = vbYes Then
On Error GoTo sonraki
For Each f In fs.GetFolder(yol).subfolders
Liste1 (f.Path)
sonraki:
Next
End If

Set fL = Nothing

End Sub

 

[soneravci]

Sorunuzu sorarken alın yaparak sorarsanız iyi olur çünkü buradaki yazılı kodlar birden fazla kişiye ait

Alternatif olarak aşağıdaki kodu deneyiniz.

kod:

Dim msg1 As String

Sub dosyaListele()

msg1 = MsgBox("Alt klasör dahil edilsinmi.? ", vbYesNo + vbInformation, "u y a r ı !")
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
Range("A1") = "Dosya Yolu"
Range("B1") = "Dosya Adı"
Range("C1") = "Dosya Tipi"
Range("D1") = "Dosya Boyutu"
Range("E1") = "Oluşturulma Tarihi"
Range("F1") = "Son Erişim Tarihi"
Range("G1") = "Son Düzenleme Tarihi"
Range("H1") = "Son Düzenleme Zamanı"

Liste1 (Kaynak)
MsgBox "işlem tamam !", vbInformation, "DİKKAT"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
Set Obj = Nothing
Set Klasor = Nothing

End Sub





Private Sub Liste1(yol As String)

Dim fs As Object, f As Object, j As Long
Set fs = CreateObject("Scripting.FileSystemObject")

For Each Dosya In fs.GetFolder(yol).Files
Uzanti = fs.GetExtensionName(Dosya)
If Uzanti = [COLOR="Red"]"xls"[/COLOR] Or Uzanti = [COLOR="red"]"xlsx"[/COLOR] Then

j = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A1:A" & Rows.Count)) + 1

Cells(j, 1) = Dosya
Cells(j, 2) = Dir(Dosya)

With fs.GetFile(Dosya)
ActiveSheet.Hyperlinks.Add Anchor:=Range("B" & j), Address:=Dosya
Range("C" & j) = .Type
Range("D" & j) = Format(.Size / 1024, "#,##0.0000") & " Kb"
Range("E" & j) = Format(.DateCreated, "dd.mm.yyyy")
Range("F" & j) = Format(.DateLastAccessed, "dd.mm.yyyy")
Range("G" & j) = Format(.DateLastModified, "dd.mm.yyyy")
Range("H" & j) = Format(.DateLastModified, "hh:mm:ss")
End With
End If
Next

If msg1 = vbYes Then
On Error GoTo sonraki
For Each f In fs.GetFolder(yol).subfolders
Liste1 (f.Path)
sonraki:
Next
End If

Set fL = Nothing

End Sub

kod için teşekkür ederim
haklısınız tabii hangi kod ile çalışmak istediğim anlaşılmıyor. nitekim benim istediğim zaten işlemleri kısaltmak adına hiç bir sorgu yapmaması ve bana hangi klasör olduğunu sormaması. Sadece bulunduğu klasörün içindeki dosyaları alt klasörlere bakmadan (ki zaten yok), açılır açılmaz kendi başına listelemesi.

bunun dışında yazdığınız kod tam aradığım özelliklere sahip teşekkür ederim.

 

[halit3]

kod için teşekkür ederim
haklısınız tabii hangi kod ile çalışmak istediğim anlaşılmıyor. nitekim benim istediğim zaten işlemleri kısaltmak adına hiç bir sorgu yapmaması ve bana hangi klasör olduğunu sormaması. Sadece bulunduğu klasörün içindeki dosyaları alt klasörlere bakmadan (ki zaten yok), açılır açılmaz kendi başına listelemesi.

bunun dışında yazdığınız kod tam aradığım özelliklere sahip teşekkür ederim.

Kod bulunduğu klasörün içindeki dosyaları listeliyor.
Kırmızı renkli yer dosyaların bulunduğu adres siz bunu değiştirebilirsiniz.

Sub dosyaListele()
Dim fs As Object, j As Long
Set fs = CreateObject("Scripting.FileSystemObject")
yol = [COLOR="Red"]ThisWorkbook.Path[/COLOR]

Cells.ClearContents
Range("A1") = "Dosya Yolu"
Range("B1") = "Dosya Adı"
Range("C1") = "Dosya Tipi"
Range("D1") = "Dosya Boyutu"
Range("E1") = "Oluşturulma Tarihi"
Range("F1") = "Son Erişim Tarihi"
Range("G1") = "Son Düzenleme Tarihi"
Range("H1") = "Son Düzenleme Zamanı"

For Each Dosya In fs.GetFolder(yol).Files
Uzanti = fs.GetExtensionName(Dosya)
If Uzanti = "xls" Or Uzanti = "xlsx" Then

j = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A1:A" & Rows.Count)) + 1

Cells(j, 1) = Dosya
Cells(j, 2) = Dir(Dosya)

With fs.GetFile(Dosya)
ActiveSheet.Hyperlinks.Add Anchor:=Range("B" & j), Address:=Dosya
Range("C" & j) = .Type
Range("D" & j) = Format(.Size / 1024, "#,##0.0000") & " Kb"
Range("E" & j) = Format(.DateCreated, "dd.mm.yyyy")
Range("F" & j) = Format(.DateLastAccessed, "dd.mm.yyyy")
Range("G" & j) = Format(.DateLastModified, "dd.mm.yyyy")
Range("H" & j) = Format(.DateLastModified, "hh:mm:ss")
End With
End If
Next


MsgBox "işlem tamam !", vbInformation, "DİKKAT"
End Sub