Çözüldü ağdaki klasör ve alt klasörleri excel'de listeleme

[tukayf]

Merhabalar. Ağda ya da belli bir dizinde bulunan klasör ve bu klasörlerin içerisinde alt alta oluşturulmuş dizinlerdeki tüm klasör isimlerini listeleyecek kod oluşturulabilir mi acaba?
Dizinde iç içe 20 den fazla alt klasör var.
Forum da ve nette bulduklarımın bazıları 3 klasöre kadar getiriyor bazılarında ise dizin seçemiyorum. Ağdaki klasörleri gösteremiyorum.

 

[Haluk]

Merhaba;

Dosyaya yeni bir modül ilave edip, aşağıdakileri yapıştırdıktan sonra "Test" isimli makroyu çalıştırın, gerekirse kodu kendinize göre revize edersiniz.

Public j
'
Sub Test()
    Set ObjFolder = CreateObject("Shell.Application").BrowseForFolder _
                    (0, "Lütfen bir klasor seçin !", &H100)
    MyPath = ObjFolder.Items.Item.Path
    ListFolders (MyPath)
End Sub
'
Sub ListFolders(MyPath)
    Dim FSO As Object, MyFolder As Object
    Dim AllSubFolders As Object, MySubFolder As Object
    Dim MyFold As String
    On Error Resume Next
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set MyFolder = FSO.GetFolder(MyPath)
    Set AllSubFolders = MyFolder.SubFolders
    For Each MySubFolder In AllSubFolders
        j = j + 1
        MyFold = MySubFolder.Path
        Cells(j, 1) = MyFold
        ListFolders (MySubFolder.Path)
    Next
End Sub

.

 

[tugkan]

Merhaba,
Ekteki dosyayı en üst klasöre kaydetip çalıştırın. Ben de dosyayı @leumruk Hocamdan almıştım. Ya da o yapmış zamanında hatırlamıyorum.
Umarım işinizi görür.

 

[Orion1]

Merhaba;

Dosyaya yeni bir modül ilave edip, aşağıdakileri yapıştırdıktan sonra "Test" isimli makroyu çalıştırın, gerekirse kodu kendinize göre revize edersiniz.

Public j
'
Sub Test()
    Set ObjFolder = CreateObject("Shell.Application").BrowseForFolder _
                    (0, "Lütfen bir klasor seçin !", &H100)
    MyPath = ObjFolder.Items.Item.Path
    ListFolders (MyPath)
End Sub
'
Sub ListFolders(MyPath)
    Dim FSO As Object, MyFolder As Object
    Dim AllSubFolders As Object, MySubFolder As Object
    Dim MyFold As String
    On Error Resume Next
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set MyFolder = FSO.GetFolder(MyPath)
    Set AllSubFolders = MyFolder.SubFolders
    For Each MySubFolder In AllSubFolders
        j = j + 1
        MyFold = MySubFolder.Path
        Cells(j, 1) = MyFold
        ListFolders (MySubFolder.Path)
    Next
End Sub

.

 

[tukayf]

Öncelikle cevaplar için teşekkür ederim. Sn. tuğkan önerdiğiniz dosyayı denedim ancak yeterli sayıda alt klasörü getirmiyor.
Sn. Haluk hocam öncelikle teşekkürler. Dosyanızda bilgisayarın kendi dizinlerinde istediğim kadar dosyayı getiriyor çok teşekkürler. Ancak ağ dosyalarını göremiyorum. Bunun için bir yol tanımlayabilir misiniz sürekli o yolda aratsa mümkün müdür?

 

[Haluk]

Kodun ilk çalıştırıldığında çıkan pencerede hem yerel bilgisayarı hem de ağa ulaşacak yeri görebilmeniz gerekir.

Her neyse; ağdaki klasör ismi standart olacaksa; koddaki sadece "Test" isimli makroyu silin, yerine aşağıdakini yapıştırıp, çalıştırın...

Sub Test()
    ListFolder ("\\Falan_Bilgisayar\Filan_Klasor")
End Sub

.

 

[tukayf]

Sn. Haluk Hocam. Ağı görüyorum ancak bana lazım olan ağ bilgisayarı gelmiyor bende anlayamadım hepsi geliyor sadece o gelmiyor.
Sub Test()
ListFolder ("\\Falan_Bilgisayar\Filan_Klasor")
End Sub
ancak bu verdiğiniz kodla sorunu kökten çözdüm çok teşekkürler.

 

[tukayf]

Sn. Hocam bu dosya yollarını köprü olarak alabilmemiz mümkün müdür acaba.

 

[Haluk]

Günaydın;

Aşağıdaki şekilde deneyin...

Public j
'
Sub Test()
    ListFolder ("\\Falan_Bilgisayar\Filan_Klasor")
End Sub
'
Sub ListFolders(MyPath)
    Dim FSO As Object, MyFolder As Object
    Dim AllSubFolders As Object, MySubFolder As Object
    Dim MyFold As String
    On Error Resume Next
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set MyFolder = FSO.GetFolder(MyPath)
    Set AllSubFolders = MyFolder.SubFolders
    For Each MySubFolder In AllSubFolders
        j = j + 1
        MyFold = MySubFolder.Path
        Cells(j, 1) = MyFold
        Cells(j, 1).Hyperlinks.Add Cells(j, 1), MyFold, , "Klasore ulasmak icin tiklayin"
        ListFolders (MySubFolder.Path)
    Next
End Sub

.

 

[tukayf]

Sizlere de günaydın hocam. Çok teşekkürler.

 

[sinan05]

iyi günler. Bende bu konuda yardımınızı rica edebilirmiyim. çalışma kitabıma Aşağıya eklediğim makro ile kayıtlar klosörünün içindeki satışta adındaki alt klosörde bulunan dosyadan veri çekiyorum. şimdi kayıtlar klosörüne bir kaç alt klosör daha ekledim. istediğim kayıtlar klosöründe nekadar alt klosör varsa içindeki dosyalardaki aşağıdaki kodlarda belirtilen verileri çekmek. Lütfen bana da yardım edermisiniz.

Sub Dosyalardan_Urun_Getir()
Application.ScreenUpdating = False
Dim evn As Object, klasoradi As String, kitap As Workbook
Dim i As Integer, x As Integer, dosyam As Workbook
Set kitap = ThisWorkbook
kitap.Sheets("ANA SAYFA").Range("a3:I65536").ClearContents
klasoradi = "KAYITLAR\SATIŞTA"
Set evn = CreateObject("scripting.filesystemobject")
Set dosyalar = evn.getfolder(ThisWorkbook.Path & Application.PathSeparator & klasoradi)
For Each klasor In dosyalar.Files
Set dosyam = GetObject(klasor.Path)
For i = 1 To dosyam.Sheets.Count
For x = 2 To 2

dosyam.Sheets(i).Range("a" & x & ":ı" & x).Copy
kitap.Sheets("ANA SAYFA").Range("a65536").End(3)(2, 1).PasteSpecial xlPasteValues
Next x
Next i
dosyam.Close False
Next klasor

Range("M5").Select
Set evn = Nothing: Set kitap = Nothing: Set dosyam = Nothing
Application.ScreenUpdating = True
End Sub