Klasör ve Dosya Listele

ikikan

Altın Üye
Katılım
3 Mart 2009
Mesajlar
467
Excel Vers. ve Dili
excel 2003 tr
Arkadaşlar Bu forumda Zamanında indirdiğim bir dosyada yardıma ihtiyacım var.
listelediğim klasörleri excel sayfasına aralarında boşluk olmadan aktaramıyorum, yardım için şimdiden teşekkürler.

Örnek dosya ektedir



Kod:
Public konumSat As Integer
Public konumSut As Integer
Sub DosyaListeYapı()
 konumSat = 0
 konumSut = 0
 Application.FileDialog(msoFileDialogFolderPicker).Show
 Range("B1").Value = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
 Range("B6:Z10000").Clear
 secimAdi = Right(Range("B1").Value, (Len(Range("B1").Value) - Len(Application.FileDialog(msoFileDialogFolderPicker).InitialFileName)))
 Range("B6").Hyperlinks.Add Anchor:=Range("B6"), Address:=Range("B1"), TextToDisplay:=UCase(secimAdi)
 Range("B6").Font.Color = vbBlack
 Range("B6").Font.Bold = True
 Call KlasorDosyaListe(Range("B1").Value)
End Sub

Private Sub FormatTemizle(Rng As Range)
    Rng.Formula = Rng.Value2
    Rng.Font.ColorIndex = xlAutomatic
    Rng.Font.Underline = xlUnderlineStyleNone
End Sub

Function KlasorDosyaAdi(ByVal Yol As String) As String
    If Right$(Yol, 1) <> "\" And Len(Yol) > 0 Then
        KlasorDosyaAdi = KlasorDosyaAdi(Left$(Yol, Len(Yol) - 1)) + Right$(Yol, 1)
    End If
End Function


Function KlasorDosyaListe(KlasorAdi As String) As Boolean
    On Error Resume Next
    Dim FSO, YeniKlasor, KlasorDizi, DosyaDizi, YeniDosya
    Dim OriginalRange As Range
    Dim KopruSil As Boolean
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    If Err.Number > 0 Then
        KlasorDosyaListe = False
    Exit Function
    End If
    
    
    If FSO.FolderExists(KlasorAdi) Then
        Set YeniKlasor = FSO.GetFolder(KlasorAdi)
        Set KlasorDizi = YeniKlasor.SubFolders
        Set DosyaDizi = YeniKlasor.Files
        KopruSil = False
        Set OriginalRange = Range("A2").Offset(konumSat - 1, konumSut)
        konumSut = konumSut + 1

        For Each YeniKlasor In KlasorDizi
            Range("A7").Offset(konumSat, konumSut).Hyperlinks.Add Anchor:=Range("A7").Offset(konumSat, konumSut), Address:=YeniKlasor, TextToDisplay:=UCase(KlasorDosyaAdi(YeniKlasor))
            Range("A7").Offset(konumSat, konumSut).Font.Color = vbRed
            

            KlasorDosyaListe (YeniKlasor)
            konumSat = konumSat + 1
            'KopruSil = True
        Next YeniKlasor

  
        For Each YeniDosya In DosyaDizi
            Range("A7").Offset(konumSat, 14).Hyperlinks.Add Anchor:=Range("A7").Offset(konumSat, 14), Address:=YeniDosya, TextToDisplay:=KlasorDosyaAdi(YeniDosya)
            Range("A7").Offset(konumSat, 14).Font.Color = vbBlue
            konumSat = konumSat + 1
            KopruSil = False
            DoEvents
        Next YeniDosya

        If KopruSil Then
            Call FormatTemizle(OriginalRange)
        End If

        Set YeniKlasor = Nothing
        Set KlasorDizi = Nothing
        Set DosyaDizi = Nothing
        Set YeniDosya = Nothing
    
    Else
        KlasorDosyaListe = False
    End If

    Set FSO = Nothing
    konumSut = konumSut - 1

End Function
 

Ekli dosyalar

kulomer46

Altın Üye
Altın Üye
Katılım
23 Mart 2007
Mesajlar
1,132
Excel Vers. ve Dili
excel 2013 türkçe
Değerli Arkadaşım Merhaba

Dosyanız üzerinde çalışarak talebinizi karşılayan Ek 'teki dosyayı ekliyorum.
Sayfayı boş satır ve sütun bulunmayacak hale getirme işlemi sizin önceki kodlarınızın aktarma işlemi bittikten sonra sadece 15-25 Sn. arası ek süre almaktadır.

Selamlar...
 

Ekli dosyalar

ikikan

Altın Üye
Katılım
3 Mart 2009
Mesajlar
467
Excel Vers. ve Dili
excel 2003 tr
Teşekkürle: Fakat bende 10000 yakın veri olduğu için makro çok uzun sürüyor, İlginize teşekkür.
Benim daha farklı bir mantık bulmam lazım.
 

ikikan

Altın Üye
Katılım
3 Mart 2009
Mesajlar
467
Excel Vers. ve Dili
excel 2003 tr
226882

Yukardaki süre çıkıyor ortaya birde veri sürekli artan bir veri.
 

ikikan

Altın Üye
Katılım
3 Mart 2009
Mesajlar
467
Excel Vers. ve Dili
excel 2003 tr
Korhan Bey güzel örnek bir çalışma, Siz den aldığım daha önceki bir, hata bir kaç dosya ile bu şekil de çalışıyorum. O yardımlar için teşekkürler.
Benim amacım Boş klasörleri de bulabilmek . Nedeni Veri klasöründe çok fazla yerine konulmamış evrak var onları tespit edip ilgili klasöre evrakları atmam lazım.

Pdf veya herhangi bir dosya yoksa son klasörde. Boş yazması varsa pdf'nin veya diğer formatların gelmesi.
 

Korhan Ayhan

Moderatör
Yönetici
Katılım
15 Mart 2005
Mesajlar
31,837
Excel Vers. ve Dili
Ofis 365 Tr-64 Bit
Ofis 2010 Tr-En 32 Bit
Paylaştığım dosyaya boş klasörleri listeleyecek özelliği ekledim. Aynı zamanda boş olan klasörlere ait satırlara sarı renk dolgu uygulanıyor. Deneyiniz.
 

ikikan

Altın Üye
Katılım
3 Mart 2009
Mesajlar
467
Excel Vers. ve Dili
excel 2003 tr
Paylaştığım dosyaya boş klasörleri listeleyecek özelliği ekledim. Aynı zamanda boş olan klasörlere ait satırlara sarı renk dolgu uygulanıyor. Deneyiniz.
Gayet iyi Korhan Bey Teşekkürler işime yarayacaktır. Yanlış anlamasanız.

Bu bölüm B1 hücresinde var bunu tüm klasör adreslerinde belirtmesek nasıl yaparız.

D:\Onay Makamı ve Teknik Servis Dökümanları\Temel Araç Uygunluk Belgeleri
 

ikikan

Altın Üye
Katılım
3 Mart 2009
Mesajlar
467
Excel Vers. ve Dili
excel 2003 tr
Örnek: B2 hücresine yazılandan sonrakileri
Sadece Yeşil olarak işaretli yer olabilirim.

D:\Onay Makamı ve Teknik Servis Dökümanları\Temel Araç Uygunluk Belgeleri\AUNDE\2EKE2\M2\B\3880 kg\4+1\Uzun\(9+1)P
 
Üst