İlk karakteri A olan alt klasörlerin içindeki klasörlerde bulunan txt dosyalarının sayıları

[Tevfik_Kursun]

Merhaba Arkadaşlar,
excel dosyanın bulunduğu klasördeki DATA_2025 klasöründeki altklasörleri listeliyor. İlk karakteri A olan altlasörlerin içindeki klasöerlerde bulunan txt dosyalarının
Z13 e 6 basamaklı adı olanların sayıları
Z14 e 7 basamaklı adı olanların sayıları
Z15 e 9 basamaklı adı olanların sayılarını nasıl bulabilirim?
Saygılarımla

 

[haliliyas]

mesela DATA_2025 klasörünün altında \Bolu\Adana\ alt klasörü varsa oradaki dosyalar da sayılacak mı
ayrıca uzantılar da dahil mi?
aşağıdaki kodu dener misiniz?
kodun tamamı bir modüle aktarılacak
Not: Alt alta bir çok seviyede alt klasör olduğu varsayılmıştır
DATA_2025 \Bolu\Adana\ mesela bu yapıda Bolu içindeki txt dosaları sayılmamıştır ama Bolu'nun alt klasörü olan Adana klasörü içindeki txt dosyaları sayılmıştır.

Dim xUzun6 As Long, xUzun7 As Long, xUzun9 As Long, xUzun As Long

Sub VeriSay()
t1 = Timer
Dim AnaKlsr As String
AnaKlsr = ThisWorkbook.Path & "\DATA_2025"
If Dir(AnaKlsr, vbDirectory) <> "" Then DosyaListele AnaKlsr
t2 = Timer
Debug.Print t2 - t1, xUzun6, xUzun7, xUzun9, xUzun

End Sub

Function DosyaListele(ByVal AnaKlsr As String)
Dim FSO As Object '//FileSystemObject
Dim f As Object '//File Object
 
 Set FSO = CreateObject("Scripting.FileSystemObject")
With FSO
    'dosya listesi
    If Left(.GetFolder(AnaKlsr).Name, 1) = "A" Then 'ilk harf A  ise
    dosyaAdi = Dir(AnaKlsr & "\*.txt") ' İlk .txt dosyasını bul
    Do While dosyaAdi <> ""
                If Len(dosyaAdi) = 6 + 4 Then
                   xUzun6 = xUzun6 + 1
                ElseIf Len(dosyaAdi) = 7 + 4 Then
                  xUzun7 = xUzun7 + 1
                ElseIf Len(dosyaAdi) = 9 + 4 Then
                  xUzun9 = xUzun9 + 1
                Else
                  xUzun = xUzun + 1 'farklı uzunluklar için
                End If
        dosyaAdi = Dir ' Bir sonraki dosyayı al
    Loop
    End If
    
    'klasör Listesi
    For Each itm In .GetFolder(AnaKlsr).SubFolders
        DosyaListele itm
    Next itm
End With
End Function

 

[Tevfik_Kursun]

Sayın Halil İlyas Hocam,
Öyle bir karmaşa yok zaten. Altklasörlerdeki klasörler ilki harf olmak üzere 6 karakterli. Makro hiç tepki vermedi. İlginize çok teşekkür ederim
Saygılarımla

 

[Tevfik_Kursun]

Sayın Tahsin Hocam,
Siz yazdığınızı kaldırdınız sanırım. Sizin makro çalıştı. Şimdi de döngü ile deneyeceğim. O da mutlaka çalışır. İlginize teşekkür ederim.
Saygılarımla

 

[haliliyas]

hocam makro ekrana yazıyor isterseniz aktif sayfaya aktarmasını sağlayabilirsiniz.
kodu aşağıdaki gibi düzenleyip dener misiniz?

Dim xUzun6 As Long, xUzun7 As Long, xUzun9 As Long, xUzun As Long, xSay

Sub VeriSay()
t1 = Timer
Dim AnaKlsr As String
AnaKlsr = ThisWorkbook.Path & "\DATA_2025"

xUzun6 = 0
xUzun7 = 0
xUzun9 = 0
xUzun = 0
xSay = 0
If Dir(AnaKlsr, vbDirectory) <> "" Then DosyaListele_hy AnaKlsr
Range("z13") = xUzun6
Range("Z14") = xUzun7
Range("Z15") = xUzun9
t2 = Timer
Debug.Print t2 - t1, xSay, xUzun6, xUzun7, xUzun9, xUzun

End Sub

Function DosyaListele_hy(ByVal AnaKlsr As String)
Dim FSO As Object '//FileSystemObject
Dim f As Object '//File Object

Set FSO = CreateObject("Scripting.FileSystemObject")
With FSO
   
    'dosya listesi
    If Left(.GetFolder(AnaKlsr).Name, 1) = "A" Then 'ilk harf A  ise
    dosyaAdi = Dir(AnaKlsr & "\*.txt") ' İlk .txt dosyasını bul
    Do While dosyaAdi <> ""
    xSay = xSay + 1
                If Len(dosyaAdi) = 6 + 4 Then
                   xUzun6 = xUzun6 + 1
                ElseIf Len(dosyaAdi) = 7 + 4 Then
                  xUzun7 = xUzun7 + 1
                ElseIf Len(dosyaAdi) = 9 + 4 Then
                  xUzun9 = xUzun9 + 1
                Else
                  xUzun = xUzun + 1 'farklı uzunluklar için
                End If
        dosyaAdi = Dir ' Bir sonraki dosyayı al
    Loop
    End If
   
    'klasör Listesi
    For Each itm In .GetFolder(AnaKlsr).SubFolders
        DosyaListele_hy itm
    Next itm
End With

End Function

 

[Tevfik_Kursun]

Sayın Halil İlyas Hocam,
İlginize teşekkür ederim. Bu sefer sıfır olarak geldi
Saygılarımla

 

[haliliyas]

Hocam harici bir siteye örnek dosya eklemeniz mümkün mü?
Çıkması gereken sonucu da yazarsanız sevinirim.

 

[Tevfik_Kursun]

Sayın Halil İlyas Hocam,
İlginize teşekkür ederim
İyi Bayramlar

Buyrun
Deneme

 

[haliliyas]

Hocam maalesef dosya indirme yetkim yok o nedenle harici siteye yüklemeniz istemiştim.
Not : sadece dosya değil örnek klasör alt klasör ve txt dosyaları da olsa fena olmaz.

 

[Tevfik_Kursun]

Buyrun yazısının altında harici link var (Deneme) arkadaşım, birazdan txt dosyalarını da gönderirim

 

[haliliyas]

Kusura bakmayın hocam telefondan bakıyordum, dikkatinden kaçmış. Siz söyleyince fark ettim.

 

[haliliyas]

kodlu haliyle ekler misiniz?
5. mesajdki kodda fazladan bir satır kalmış -bendeki hedef klasörü gösteren satır-onu sildim. 5. mesajdaki kodu tekrar kontrol edip dener misiniz

 

[Tevfik_Kursun]

https://s6.dosya.tc/server22/bu8m2l/Dene.rar.html
iyi çalışmalar

 

[tahsinanarat]

Sn. Tevfik Kursun Z1 Hücresine yazılı harfe göre ve HarHarf arama yapacak şekildeki örnek dosyayı incelermisiniz

 

[haliliyas]

İlk karakteri A olan altlasörlerin içindeki klasöerlerde bulunan txt dosyalarının

kodun çalışmaması normal çünkü yukardaki ifadenizde "A" ile başlayan alt klasörlerden bahsetmiştiniz oysa txt dosyaları txt alt klasörlerinin içinde.
kod ise If Left(.GetFolder(AnaKlsr).Name, 1) = "A" satırı ile ilgili klasörün A harfi ile başlayıp başlamadığını kontrol ediyor, txt klasörü A ile başlamadığından içeriğine bakmıyor.

 

[haliliyas]

açıklamanızı yeni duruma göre yeniden yapar mısınız?
anladığım DATA_2025 klasörünün içinde A ile başlayan alt klasörlerin içindeki txt klasörlerinin içindeki metin dosyaları mı sayılacak?
örneğinize göre
....\DATA_2025\A25001\Txt
....\DATA_2025\A25002\Txt
alt dizinlerindekiler sayılacak
ama .....\Asil\DATA_2025\B25001\Txt içindekiler sayılmayacak öyle mi?

 

[haliliyas]

diğer kodların hepsini silip aşağıdaki kodu dener misiniz?

Sub VeriSay()
Dim AnaKlsr As String
Dim xUzun6 As Long, xUzun7 As Long, xUzun9 As Long
AnaKlsr = ThisWorkbook.Path & "\DATA_2025"

xUzun6 = 0
xUzun7 = 0
xUzun9 = 0

If Dir(AnaKlsr, vbDirectory) <> "" Then 'DosyaListele_hy AnaKlsr
Dim FSO As Object '//FileSystemObject
Dim f As Object '//File Object

    Set FSO = CreateObject("Scripting.FileSystemObject")
    With FSO
        'Klasör listesi
     For Each itm In .GetFolder(AnaKlsr).SubFolders
        If Left(itm.Name, 1) = "A" Then 'ilk harf A  ise
        'dosya listesi
        DosyaAdi = Dir(itm & "\Txt\*.txt") ' İlk .txt dosyasını bul
        Do While DosyaAdi <> ""
                    If Len(DosyaAdi) = 6 + 4 Then
                       xUzun6 = xUzun6 + 1
                    ElseIf Len(DosyaAdi) = 7 + 4 Then
                      xUzun7 = xUzun7 + 1
                    ElseIf Len(DosyaAdi) = 9 + 4 Then
                      xUzun9 = xUzun9 + 1
'                    Else
'                      xUzun = xUzun + 1 'farklı uzunluklar için
                    End If
            DosyaAdi = Dir ' Bir sonraki dosyayı al
        Loop
        End If
    Next itm   
    End With
End If
Range("z13") = xUzun6
Range("Z14") = xUzun7
Range("Z15") = xUzun9

End Sub

 

[Tevfik_Kursun]

Sayın Tahsin Hocam,
İlginize teşekkür ederim. Önceki gün israrla ChatGPT ye yaptırmaya çalıştım, istediğimi yapamadı. Bunun üzerine onun verdiğine kendi çalışmamı uydurarak problemi çözdüm. Bu arada siteye de yazmıştım. Verdiğiniz cevabı toparlayarak sizin gönderdiğiniz dosyanın aynını hazırladım. Gayet güzel çalışıyor. Ayrıca makronuzu bir daha inceleyeceğim. İlginize teşekkür eder, bu vesileyle iyi bayramlar dilerim.
Saygılarımla

 

[Tevfik_Kursun]

Sayın Halil İlyas Hocam,
Demek tam anlatamamışım. Olsun, gönderdiğiniz makro gayet güzel çalışıyor. İnceleyip elimdekilerle karşılaştırarak konuyu daha güzel kavrayacağım. İlginize teşekkür eder, bu vesileyle iyi bayramlar dilerim.
Saygılarımla

 

[haliliyas]

Rica ederim
İyi çalışmalar