excel alt klasörlerden satırlara dosya listesi

[erdinc_isik2@hotmail.com]

Merhaba
Elimde barkod numaralarıyla klasörler ve bu klasörlerde görseller var ve adet çok fazla
a1 hücresine klasör adı b1 hücresine bu klasördeki dosya1 , c1 hücresine bu klasördeki dosya2 ......
a2 hücresine klasör adı b2 hücresine bu klasördeki dosya1 , c2 hücresine bu klasördeki dosya2 ......
gibi o dosyalar hangi klasörde ise o klasörün satırına sırasıyla yazılması gerekiyor
tüm klasörler, aynı klasörde ve alt klasörleri yok, kiminde 2 dosya kiminde 15 dosya var
ben a1 klasör adı , a2 dosya1, a3 dosya2 .... şeklinde yaptım ama adet çok fazla manuel olarak tek tek sütunlara taşıyorum
yardımcı olabilirseniz sevinirim

 

[erdinc_isik2@hotmail.com]

bu kod u

tree /A /F > tree.txt

.cmd olarak kaydedip çalıştırdığımda bana klasördeki tüm dosyaları ve alt klasörlerdeki dosyaları bulundukları klasör adının altına alt alta metin belgesi olarak hazırlıyor
excele aldığımda tek sütunda tüm klasörler ve içlerindeki dosyalar var
manuel olarak klasör içindekileri aynı satırda sütunlara dağıtıyorum sonrada boşluk sil makrosuyla

Sub BOŞ_SATIR_SİL()
    On Error GoTo Son
    [A:A].SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Son:
End Sub

boş satırları siliyorum
onbinlerce dosya var bilen varsa lütfen yardım etsin

 

[Korhan Ayhan]

Örnek klasör paylaşınız. Eğer alt klasörler varsa bu şekilde örnek paylaşınız.

Sıkıştırıp paylaşım sitelerine yükleyip link verebilirsiniz.

Paylaştığınız örneğe göre sonucu şu şekilde görmek istiyorum şeklinde manuel olarak sonuç tablosunu da paylaşınız.

 

[erdinc_isik2@hotmail.com]

örnek dosya için tıklayınız

ilginiz için teşekkürler

 

[Korhan Ayhan]

Klasörlerinizde sadece"jpg" uzantılı dosyalar mı var?

 

[erdinc_isik2@hotmail.com]

Klasörlerinizde sadece"jpg" uzantılı dosyalar mı var?

evet tamamı .jpg

 

[Korhan Ayhan]

Aşağıdaki kodu boş bir modüle ekleyip çalıştırın.

Kodu çalıştırdığınızda sizden resimlerin olduğu klasörü seçmenizi isteyecek. Yaptığınız seçime göre liste oluşacaktır.

Option Explicit

Dim Sayfa As Worksheet, Klasor As Variant, Zaman As Double
Dim Dosyalar As Object, Dosya As Object, Alt_Klasor As Object
Dim Satir As Long, Sutun As Integer, Son_Sutun As Integer, X As Integer

Sub Secilen_Klasor_Altindaki_Klasorleri_ve_Dosyalari_Listele()
    Set Klasor = CreateObject("Shell.Application").BrowseForFolder(0, "Kaynak dosyaları içeren klasörü seçiniz...", 0, &H0)
    
    If Klasor Is Nothing Then
        MsgBox "İşleme devam edebilmeniz için klasör seçmelisiniz!", vbCritical
        Exit Sub
    End If

    Zaman = Timer
    
    Application.ScreenUpdating = False
    
    Set Sayfa = ActiveSheet
    
    Sayfa.Cells.Delete
    Son_Sutun = 0

    Klasor = Klasor.Self.Path
    
    Listele (Klasor)
    
    If Son_Sutun = 0 Then
        Set Sayfa = Nothing
        Set Klasor = Nothing
        
        Application.ScreenUpdating = True
        
        MsgBox "Listelenecek dosya bulunamadı!", vbCritical
    Else
        Sayfa.Cells(1, 1) = "Klasör Adı"
        
        For X = 2 To Son_Sutun - 1
            Sayfa.Cells(1, X) = "Resim " & X - 1
        Next
        
        Sayfa.Range("A1").Resize(1, Son_Sutun - 1).Font.Bold = True
        
        Sayfa.Columns.AutoFit
    
        Set Sayfa = Nothing
        Set Klasor = Nothing
        
        Application.ScreenUpdating = True
        
        MsgBox "Seçtiğiniz klasör altındaki klasör ve dosyalar listelenmiştir." & Chr(10) & Chr(10) & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
    End If
End Sub

Sub Listele(Yol As String)
    Satir = Sayfa.Cells(Sayfa.Rows.Count, 1).End(3).Row + 1
    Sutun = 2
    
    Set Dosyalar = CreateObject("Scripting.FileSystemObject").GetFolder(Yol).Files
    
    For Each Dosya In Dosyalar
        If UCase(CreateObject("Scripting.FileSystemObject").GetExtensionName(Dosya)) = "JPG" Then
            Sayfa.Cells(Satir, 1) = CreateObject("Scripting.FileSystemObject").GetParentFolderName(Dosya)
            Sayfa.Hyperlinks.Add Anchor:=Sayfa.Cells(Satir, 1), _
            Address:=Dosya.ParentFolder.Path, TextToDisplay:=Sayfa.Cells(Satir, 1).Value
            
            Sayfa.Cells(Satir, Sutun) = Dosya.Name
            Sayfa.Hyperlinks.Add Anchor:=Sayfa.Cells(Satir, Sutun), _
            Address:=Dosya.Path, TextToDisplay:=Dosya.Name
            Sutun = Sutun + 1
            If Sutun > Son_Sutun Then Son_Sutun = Sutun
        End If
    Next

    Satir = Sayfa.Cells(Sayfa.Rows.Count, 1).End(3).Row + 1

    On Error Resume Next
    
    For Each Alt_Klasor In CreateObject("Scripting.Filesystemobject").GetFolder(Yol).SubFolders
        Call Listele(Alt_Klasor.Path)
    Next

    On Error GoTo 0

    Set Dosyalar = Nothing
End Sub

 

[erdinc_isik2@hotmail.com]

Aşağıdaki kodu boş bir modüle ekleyip çalıştırın.

Kodu çalıştırdığınızda sizden resimlerin olduğu klasörü seçmenizi isteyecek. Yaptığınız seçime göre liste oluşacaktır.

Option Explicit

Dim Sayfa As Worksheet, Klasor As Variant, Zaman As Double

Sub Secilen_Klasor_Altindaki_Klasorleri_ve_Dosyalari_Listele()
    Set Klasor = CreateObject("Shell.Application").BrowseForFolder(0, "Kaynak dosyaları içeren klasörü seçiniz...", 0, &H0)
   
    If Klasor Is Nothing Then
        MsgBox "İşleme devam edebilmeniz için klasör seçmelisiniz!", vbCritical
        Exit Sub
    End If

    Zaman = Timer
   
    Application.ScreenUpdating = False
   
    Set Sayfa = ActiveSheet
   
    Sayfa.Range("A2:N" & Sayfa.Rows.Count).Clear

    Klasor = Klasor.Self.Path
   
    Listele (Klasor)
   
    Set Sayfa = Nothing
    Set Klasor = Nothing
   
    Application.ScreenUpdating = True
   
    MsgBox "Seçtiğiniz klasör altındaki klasör ve dosyalar listelenmiştir." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

Sub Listele(Yol As String)
    Dim Dosyalar As Object, Dosya As Object, Alt_Klasor As Object, Satir As Long, Sutun As Integer
   
    Satir = Sayfa.Cells(Sayfa.Rows.Count, 1).End(3).Row + 1
    Sutun = 2
   
    Set Dosyalar = CreateObject("Scripting.FileSystemObject").GetFolder(Yol).Files
   
    For Each Dosya In Dosyalar
        If UCase(CreateObject("Scripting.FileSystemObject").GetExtensionName(Dosya)) = "JPG" Then
            Sayfa.Cells(Satir, 1) = CreateObject("Scripting.FileSystemObject").GetParentFolderName(Dosya)
            Sayfa.Cells(Satir, Sutun) = Dosya.Name
            Sayfa.Hyperlinks.Add Anchor:=Sayfa.Cells(Satir, Sutun), _
            Address:=Dosya.Path, TextToDisplay:=Dosya.Name
            Sutun = Sutun + 1
        End If
    Next

    Satir = Sayfa.Cells(Sayfa.Rows.Count, 1).End(3).Row + 1

    Sayfa.Columns.AutoFit
   
    On Error Resume Next
   
    For Each Alt_Klasor In CreateObject("Scripting.Filesystemobject").GetFolder(Yol).SubFolders
        Call Listele(Alt_Klasor.Path)
    Next

    On Error GoTo 0

    Set Dosyalar = Nothing
End Sub

ALLAH senden razı olsun kaç gündür uğraşıyorum tek tek çok şükür bir tıkla hallettim.
kodlarla Photoshop grafik otomasyon hakkında bi sorunun olursa mutlaka söyle hallederim fotoerce kom da iletişim bilgilerim mevcut
tekrardan teşekkür ediyorum çok sağol

 

[Korhan Ayhan]

Koda bir kaç iyileştirme yaptım.

Klasörede link ekliyor. Böylece klasörede ulaşmanız kolaylaşıyor.
Ayrıca sütun başlıkları da listelenen veriye göre otomatik revize oluyor.

Son halini kullanabilirsiniz.

 

[erdinc_isik2@hotmail.com]

Koda bir kaç iyileştirme yaptım.

Klasörede link ekliyor. Böylece klasörede ulaşmanız kolaylaşıyor.
Ayrıca sütun başlıkları da listelenen veriye göre otomatik revize oluyor.

Son halini kullanabilirsiniz.

A2 A3 A4 hariç diğerleri klasör çağırmıyor Not: bana lazım değil birinin işine yarar diye yazıyorum
Tekrardan teşekkürler

 

[Korhan Ayhan]

Küçük bir revize daha yaptım. Tekrar deneyebilir misiniz? Sorun devam ediyor mu?

 

[erdinc_isik2@hotmail.com]

Küçük bir revize daha yaptım. Tekrar deneyebilir misiniz? Sorun devam ediyor mu?

sorun yok çok güzel olmuş ellerinize sağlık