Dosya içindeki klasör isimlerini excelde listeleme

[halit3]

selam halit3
bilmek kadar değerli servet yok sanırım. Allah zihin açıklığı versin. şimdi daha güzel oldu. başarılar

iyi çalışmalar

 

[skoti]

bende tesekkür etmek istedim.
benimde cok isime yaradi

 

[duzelturgay]

Sn. Halit3 hocam ve değerli arkadaşlar

Sn. Halit3 hocam ve değerli arkadaşlar bir konuyla alakalı olarak aylardır çözülmeyi bekleyen bir sorunum ve buna mukabil çok kısıtlı hatta yok denebilecek kadar az bir excel bilgim var. öyle ki makrodan hiç anlamıyorum... forumda verilen bilgileri görnce benim hayalimin de gerçek olabileceğini anladım.

problemim şu;

Bir X klasörüm mevcut, bu klasör içinde onlarca alt klasör ve o klasörlerin her biri içerisinde onlarca alt klasör daha var, o klasörlerin içerisinde de onlarca jpg, metin belgesi, word mevcut. bana gerekli olan her bir en alt klasördeki jpg resimlerinin isimlerinin dosya yolları da dahil olmak üzere birbirlerinden virgül ile ayrılmış vaziyette excele aktarılması...

örnek vermek gerekirse ;

X/A/b/c/d (1).jpg,X/A/b/c/d (2).jpg,X/A/b/c/d (3).jpg, X/A/b/c/d (1).jpg,X/A/b/c/d (1).jpg

X/A/b/c/e (1).jpg,X/A/b/c/e (2).jpg,X/A/b/c/e (3).jpg, X/A/b/c/e (1).jpg,X/A/b/c/e (1).jpg


sadece en sondaki resmin sonuna virgül koyulmuyor. aslında bu problemin çözülmesi benim için gerçekten ütopik idi ama neler yaptığınızı görünce...

 

[halit3]

Sn. Halit3 hocam ve değerli arkadaşlar bir konuyla alakalı olarak aylardır çözülmeyi bekleyen bir sorunum ve buna mukabil çok kısıtlı hatta yok denebilecek kadar az bir excel bilgim var. öyle ki makrodan hiç anlamıyorum... forumda verilen bilgileri görnce benim hayalimin de gerçek olabileceğini anladım.

problemim şu;

Bir X klasörüm mevcut, bu klasör içinde onlarca alt klasör ve o klasörlerin her biri içerisinde onlarca alt klasör daha var, o klasörlerin içerisinde de onlarca jpg, metin belgesi, word mevcut. bana gerekli olan her bir en alt klasördeki jpg resimlerinin isimlerinin dosya yolları da dahil olmak üzere birbirlerinden virgül ile ayrılmış vaziyette excele aktarılması...

örnek vermek gerekirse ;

X/A/b/c/d (1).jpg,X/A/b/c/d (2).jpg,X/A/b/c/d (3).jpg, X/A/b/c/d (1).jpg,X/A/b/c/d (1).jpg

X/A/b/c/e (1).jpg,X/A/b/c/e (2).jpg,X/A/b/c/e (3).jpg, X/A/b/c/e (1).jpg,X/A/b/c/e (1).jpg


sadece en sondaki resmin sonuna virgül koyulmuyor. aslında bu problemin çözülmesi benim için gerçekten ütopik idi ama neler yaptığınızı görünce...

Sorunuzdan anladığımı yaptım

kod:

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