• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Dosya ve klasör listeleme

K

konas06

Katılım
27 Kasım 2007
Mesajlar
664
Excel Vers. ve Dili
ofis 2016 Türkçe
Listeleme ile ilgili bilgiyi ekte bulunan dosyada belirttiğim şekilde listeme imkanımız var mıdır.
"halit3" adlı hocamızın "Alt dosya ve klasör" konusunda verdiği kodu kullanarak 2.sayfada bir listeleme yaptım ancak bu ihtiyacımı karşılamıyor.
Sayfa1 deki gibi yapmamız mümkün müdür.
Not: Konu bütünlüğü bozulma endişesiyle yeni konu açarak bilgi almak istiyorum.
 

Ekli dosyalar

Bu kodu bir dene

Kod: 
'Kaynak = ThisWorkbook.Path & "\A.Ş"

Sub verial()

Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Klasörü Seçin", 50, &H0)
If Klasor Is Nothing Then Exit Sub
Kaynak = Klasor.self.Path

Cells.ClearContents
Cells.Hyperlinks.Delete
Cells.Font.ColorIndex = 0

Cells(1, 1) = "İSİMLER"
sut = 2
sat = 1
eksi = 0

Set fL = CreateObject("Scripting.FileSystemObject")
deg1 = Split(Kaynak, "\")
'Cells(1, 1).Value = deg1(UBound(deg1)) 'fL.GetBaseName(kaynak)
Cells(1, 1).Hyperlinks.Add Anchor:=Cells(1, 1), Address:=Kaynak, SubAddress:="" & firstAddress, TextToDisplay:=deg1(UBound(deg1))

For Each f In fL.GetFolder(Kaynak).subfolders
'Cells(sat, sut) = f.Name
Cells(sat, sut).Hyperlinks.Add Anchor:=Cells(sat, sut), Address:=f.Path, SubAddress:="" & firstAddress, TextToDisplay:=f.Name
tarih = f.Name
For Each ft In fL.GetFolder(f.Path).subfolders
sut = sut + 1
'Cells(sat, sut) = ft.Name
Cells(sat, sut).Hyperlinks.Add Anchor:=Cells(sat, sut), Address:=ft.Path, SubAddress:="" & firstAddress, TextToDisplay:=ft.Name

For Each fk In fL.GetFolder(ft.Path).subfolders
sut = sut + 1
If sut >= 4 Then
End If
'Cells(sat, sut - eksi) = fk.Name
Cells(sat, sut - eksi).Hyperlinks.Add Anchor:=Cells(sat, sut - eksi), Address:=fk.Path, SubAddress:="" & firstAddress, TextToDisplay:=fk.Name

sut2 = 4
For Each fy In fL.GetFolder(fk.Path).Files
sut2 = sut2 + 1
'Cells(sat, sut2) = fL.GetBaseName(fy.Name)
Cells(sat, sut2).Hyperlinks.Add Anchor:=Cells(sat, sut2), Address:=fy, SubAddress:="" & firstAddress, TextToDisplay:=fL.GetBaseName(fy.Name)


Next
sat = sat + 1
If sut >= 4 Then
eksi = 1
End If

If sut = 5 Then
sut = 2
End If
Next
eksi = 0
Next
sut = 2
Next

MsgBox "işlem tamam"

End Sub
 
halit3' Alıntı:
Bu kodu bir dene

Kod: 
'Kaynak = ThisWorkbook.Path & "\A.Ş"

Sub verial()

Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Klasörü Seçin", 50, &H0)
If Klasor Is Nothing Then Exit Sub
Kaynak = Klasor.self.Path

Cells.ClearContents
Cells.Hyperlinks.Delete
Cells.Font.ColorIndex = 0

Cells(1, 1) = "İSİMLER"
sut = 2
sat = 1
eksi = 0

Set fL = CreateObject("Scripting.FileSystemObject")
deg1 = Split(Kaynak, "\")
'Cells(1, 1).Value = deg1(UBound(deg1)) 'fL.GetBaseName(kaynak)
Cells(1, 1).Hyperlinks.Add Anchor:=Cells(1, 1), Address:=Kaynak, SubAddress:="" & firstAddress, TextToDisplay:=deg1(UBound(deg1))

For Each f In fL.GetFolder(Kaynak).subfolders
'Cells(sat, sut) = f.Name
Cells(sat, sut).Hyperlinks.Add Anchor:=Cells(sat, sut), Address:=f.Path, SubAddress:="" & firstAddress, TextToDisplay:=f.Name
tarih = f.Name
For Each ft In fL.GetFolder(f.Path).subfolders
sut = sut + 1
'Cells(sat, sut) = ft.Name
Cells(sat, sut).Hyperlinks.Add Anchor:=Cells(sat, sut), Address:=ft.Path, SubAddress:="" & firstAddress, TextToDisplay:=ft.Name

For Each fk In fL.GetFolder(ft.Path).subfolders
sut = sut + 1
If sut >= 4 Then
End If
'Cells(sat, sut - eksi) = fk.Name
Cells(sat, sut - eksi).Hyperlinks.Add Anchor:=Cells(sat, sut - eksi), Address:=fk.Path, SubAddress:="" & firstAddress, TextToDisplay:=fk.Name

sut2 = 4
For Each fy In fL.GetFolder(fk.Path).Files
sut2 = sut2 + 1
'Cells(sat, sut2) = fL.GetBaseName(fy.Name)
Cells(sat, sut2).Hyperlinks.Add Anchor:=Cells(sat, sut2), Address:=fy, SubAddress:="" & firstAddress, TextToDisplay:=fL.GetBaseName(fy.Name)


Next
sat = sat + 1
If sut >= 4 Then
eksi = 1
End If

If sut = 5 Then
sut = 2
End If
Next
eksi = 0
Next
sut = 2
Next

MsgBox "işlem tamam"

End Sub
Genişletmek için tıkla ...

Çok güzel oldu.

Hocam bu klasör-dosya kurgusuna göre oluşturulan bir kod sanırım değil mi?
Şunu demek istiyorum, son kademe dosyadan sonra gelecek klasör belge yada dosya için koda müdahale etmek gerekecek sanırım.
Bunu başlangıç noktasını vererek son belgeye kadar ilerlemesi sağlanabilir mi?
 
bu kod daha iyi oldu


Kod: 
Dim sayi
Dim sat
Sub klasör_dosya3()

Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Klasörü Seçin", 50, &H0)
If Klasor Is Nothing Then Exit Sub
Kaynak = Klasor.self.Path
'Kaynak = ThisWorkbook.Path & "\deneme"
Cells.ClearContents
Cells.Hyperlinks.Delete
Cells.Font.ColorIndex = 0

deg1 = Split(Kaynak, "\")
Cells(1, 1).Value = deg1(UBound(deg1))
sat = 1
If UBound(deg1) > 0 Then
sayi = UBound(deg1)
End If
Liste (Kaynak)
MsgBox "işlem tamam"
End Sub
Private Sub Liste(yol As String)
Dim fL As Object, fs As Object, f As Object, j As Long, n As Long
Set fL = CreateObject("Scripting.FileSystemObject")

deg1 = Split(yol, "\")
If UBound(deg1) > 0 Then
sut = UBound(deg1) + 1 - sayi
End If

'Cells(sat, sut) = fL.GetBaseName(yol) 'dosya.Name
Cells(sat, sut).Hyperlinks.Add Anchor:=Cells(sat, sut), Address:=yol, SubAddress:="" & firstAddress, TextToDisplay:=fL.GetBaseName(yol)
fL.GetBaseName (yol)

sut = sut + 1

If fL.GetFolder(yol).Files.Count > 0 Then
sat = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
For Each dosya In fL.GetFolder(yol).Files
'Cells(sat, sut) = fL.GetBaseName(dosya.Name)  'dosya.Name
Cells(sat, sut).Hyperlinks.Add Anchor:=Cells(sat, sut), Address:=dosya, SubAddress:="" & firstAddress, TextToDisplay:=fL.GetBaseName(dosya.Name)
'sat = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
sut = sut + 1
Next
End If

On Error GoTo sonraki
For Each f In fL.GetFolder(yol).subfolders
Liste (f.Path)
sat = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
sonraki:
Next

End Sub
 
Son düzenleme:
Hocam ilginiz için teşekkür ederim.
Köprüleme de yapabilir miyiz.

Sonrasında artık bu geliştirmeye uygun bir yapı oldu.

Zamanı olan ilgilenebilecek ustalar için mümkünse bir iki rica da bulunmak istiyorum.

Örneğin listelemenin bir üst satında, yine klasör ve dosya yapısı sabit kalmak kaydıyla,
uzantıya göre arama seçeneği eklenebilir, yazdırma seçenekleri konabilir.

Forumda bir çok konudaki ihtiyacı karşılayacak hale getirilebilir.

(Tüm klasör, dosya ve belge listelemek ve yine resim, pdf, java vb dosyaları listelemek ve yazdırmak konuları ile ilgili)

Tekrar teşekkür ederim. Ellerinize sağlık.
 
4 nolu mesajdaki kod güncellendi
 
Benim gibi, araştırıp bulamayanlar için,
Seçim konumundan itibaren tüm ögeleri (Klasör, Dosya ve Belge) listelemek ve köprülemek için Halit3 Beyin verdiği kodu ekli dosyaya ekliyorum.
Daha fazla kişinin istifade edeceğini düşünüyorum.
 

Ekli dosyalar

Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst