Klasör ve Dosya Listele

[ikikan]

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

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

 

[kulomer46]

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...

 

[ikikan]

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]

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

 

[Korhan Ayhan]

İnceleyiniz.

 

[ikikan]

İnceleyiniz.

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]

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]

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

 

[Korhan Ayhan]

Deneyiniz.

 

[ikikan]

Deneyiniz.

Yanlış anlatım galiba ben. B2 hücresine yazılandan sonrakileri alabiliriyiz demek istedim .

 

[Korhan Ayhan]

Anlamadım..

 

[ikikan]

Ö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

 

[Korhan Ayhan]

Biz hiç B2 hücresini kullanmadık..

 

[Korhan Ayhan]

Deneyiniz.

 

[ikikan]

Deneyiniz.

Korhan Bey Teşekkürler işime yarayacak. Elinize sağlık

 

[ikikan]

Örnek bir dosya ekliyorum içinde 9 tane yöntem var, hatta bir çok sitede ve forumda araştırma yapmama karşın istediğim koda ulaşamadım.
Korhan beyin gönderdiği kodlar ile bir çok kod birleştirmeme rağmen istediğim sonuca ulaşamadım.
örnek bir dosya ile tekrar konuyu aktif hale getirmek istiyorum.

 

[Korhan Ayhan]

Deneyiniz.

 

[Korhan Ayhan]

Köprülerde sorun vardı. Son paylaştığım dosyayı revize ettim.

 

[okancicek]

Köprülerde sorun vardı. Son paylaştığım dosyayı revize ettim.

bende böyle excell arıyordum tesekkürler

 

[ikikan]

Üstadım kodu inceledim gayet kullanışlı, Fakat bir şeyler danışmak isterim.

Set Subfolders = Folder.Subfolders 'ile

If Alt_Klasorler_Dahilmi Then 'koda

if Subfolders.count = 0 Then 'klasör içinde klasör varsa
alt klasörleri al
else
alt klasörleri alma
End if

dene bilirmi?