Çözüldü Uzantı sayısı bulmak

k0081 · 29 Aralık 2018

Merhaba arkadaşlar ,;

Textbox a “pdf” yazıp command butona bastığımızda Aktif klasör ve alt klasörlerdeki pdf lerin toplam dosya sayısını msgbox ile nasıl alabiliriz ?

Yardımcı arkadaşa şimdiden teşekkürler

PLİNT · 29 Aralık 2018

Merhaba
Aşağıdaki gibi denermisiniz?
(Makronun çalıştırıldığı dosyanın bulunduğu klasör, yanındaki klasör (ve klasörler) ve alt klasörleri için)

Kod:

Private Sub CommandButton1_Click()
Set a = CreateObject("scripting.filesystemobject")
Set dic = CreateObject("scripting.dictionary")
dic.CompareMode = vbBinaryCompare
n = 1
yol = Split(ThisWorkbook.Path, "\")(UBound(Split(ThisWorkbook.Path, "\")))
dic.Add n, Split(ThisWorkbook.Path, yol)(0)
geri:
h = dic.Count
For j = n To h
Set klasor = a.GetFolder(dic(j))
If klasor.Subfolders.Count > 0 Then
For Each alt In klasor.Subfolders
For Each dosya In alt.Files
If a.GetExtensionName(dosya.Name) = LCase(Trim(TextBox1)) And InStr(1, dosya.Name, "$", vbTextCompare) = 0 Then

say = say + 1
End If
Next
dic.Add dic.Count + 1, alt
Next: End If: Next
If h < dic.Count Then
n = h + 1: Set klasor = Nothing:
GoTo geri: End If
MsgBox say
End Sub

k0081 · 29 Aralık 2018

PLİNT;

Hocam Merhaba.;

öncelikle Teşekkürler.

textbox a pdf şeklinde mi yazacağım yoksa *.pdf mi ?

---------------------------------

Hocam macro nun çalıştığı klasör ve alt klasörler şeklinde olabilir mi ? sayıyı veriyor ama eksik veriyor.

halit3 · 29 Aralık 2018

Alternatif kod

Kod:

Dim say
Sub pdfara()
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.self.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
say = 0
Liste (Kaynak)
MsgBox "Toplam " & say & " Dosya bulundu"
Set Klasor = Nothing
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub


Private Sub Liste(yol As String)
Dim fL As Object, f As Object
Set fL = CreateObject("Scripting.FileSystemObject")

For Each Dosya In fL.GetFolder(yol).Files
If fL.GetExtensionName(Dosya) = Textbox1.Text Then
say = say + 1
End If
Next

On Error GoTo sonraki
For Each f In fL.GetFolder(yol).subfolders
Liste (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub

PLİNT · 29 Aralık 2018

Merhaba
yukarıdaki kodlar için "pdf", "xlsx","doc" gibi; "*" ve nokta ve yazmayın

aşağıdaki gibi ise "*" , "." yazsanızda siler

Kod:

Private Sub CommandButton1_Click()
Set a = CreateObject("scripting.filesystemobject")
Set dic = CreateObject("scripting.dictionary")
dic.CompareMode = vbBinaryCompare
n = 1
yol = Split(ThisWorkbook.Path, "\")(UBound(Split(ThisWorkbook.Path, "\")))
dic.Add n, Split(ThisWorkbook.Path, yol)(0)
geri:
h = dic.Count
For j = n To h
Set klasor = a.GetFolder(dic(j))
 If klasor.Subfolders.Count > 0 Then
For Each alt In klasor.Subfolders
For Each dosya In alt.Files
If a.GetExtensionName(dosya.Name) = Lcase(Replace(Replace(Trim(TextBox1), "*", ""), ".", "")) _
And InStr(1, dosya.Name, "$", vbTextCompare) = 0 Then
say = say + 1
End If
Next
dic.Add dic.Count + 1, alt
Next: End If: Next
If h < dic.Count Then
n = h + 1: Set klasor = Nothing:
GoTo geri: End If
MsgBox say
End Sub

ilk mesajımda ki;

Kod:

If a.GetExtensionName(dosya.Name) = Trim(TextBox1) Then

şöyle değişelim

Kod:

If a.GetExtensionName(dosya.Name) = LCase(Trim(TextBox1)) And InStr(1, dosya.Name, "$", vbTextCompare) = 0 Then

k0081 · 29 Aralık 2018

halit3;

hocam kod için teşekkürler. bu kod da Plint arkadaşımızın yazmış olduğu kod gibi sonucu eksik veriyor.

126 adet olması gereken dosya; 114 çıkıyor.

PLİNT · 29 Aralık 2018

Merhaba
Aşağıdaki kodlara ek yapmaya çalıştım onu denermisiniz?
http://dosya.co/00fbdg5rox6r/DENEME.zip.html

Kod:

Private Sub CommandButton1_Click()
Set a = CreateObject("scripting.filesystemobject")
Set dic = CreateObject("scripting.dictionary")
dic.CompareMode = vbBinaryCompare
n = 1
For Each dosya In a.GetFolder(ThisWorkbook.Path).Files
If a.GetExtensionName(dosya.Name) = LCase(Trim(TextBox1)) And InStr(1, dosya.Name, "$", vbTextCompare) = 0 Then
say = say + 1
End If
Next
dic.Add n, ThisWorkbook.Path
geri:
h = dic.Count
For j = n To h
Set klasor = a.GetFolder(dic(j))
If klasor.Subfolders.Count > 0 Then
For Each alt In klasor.Subfolders
For Each dosya In alt.Files
If a.GetExtensionName(dosya.Name) = LCase(Trim(TextBox1)) And InStr(1, dosya.Name, "$", vbTextCompare) = 0 Then
say = say + 1
End If
Next
dic.Add dic.Count + 1, alt
Next: End If: Next
If h < dic.Count Then
n = h + 1: Set klasor = Nothing:
GoTo geri: End If
MsgBox say
End Sub

k0081 · 30 Aralık 2018

PLİNT' Alıntı:

Merhaba
Aşağıdaki kodlara ek yapmaya çalıştım onu denermisiniz?
http://dosya.co/00fbdg5rox6r/DENEME.zip.html

Kod:

Private Sub CommandButton1_Click()
Set a = CreateObject("scripting.filesystemobject")
Set dic = CreateObject("scripting.dictionary")
dic.CompareMode = vbBinaryCompare
n = 1
For Each dosya In a.GetFolder(ThisWorkbook.Path).Files
If a.GetExtensionName(dosya.Name) = LCase(Trim(TextBox1)) And InStr(1, dosya.Name, "$", vbTextCompare) = 0 Then
say = say + 1
End If
Next
dic.Add n, ThisWorkbook.Path
geri:
h = dic.Count
For j = n To h
Set klasor = a.GetFolder(dic(j))
If klasor.Subfolders.Count > 0 Then
For Each alt In klasor.Subfolders
For Each dosya In alt.Files
If a.GetExtensionName(dosya.Name) = LCase(Trim(TextBox1)) And InStr(1, dosya.Name, "$", vbTextCompare) = 0 Then
say = say + 1
End If
Next
dic.Add dic.Count + 1, alt
Next: End If: Next
If h < dic.Count Then
n = h + 1: Set klasor = Nothing:
GoTo geri: End If
MsgBox say
End Sub

sizin yapmış olduğunuz örnek excel de sonucu doğru veriyor. ama öyle sanıyorum ki dosya isimlendirmesinden kaynaklanıyor...

aktif klasördeki dosyayı yada alt klasörde eksik veriyor... hocam bunu başka bir şekilde yapamazmıyız ? set dic ifadesini kullanmadan.?

PLİNT · 30 Aralık 2018

"dic" sözlüğüne dosya isimleri eklenmiyor, klasörlere ait yollar ekleniyor
windows da açık (görev çubuğunda görünen) olan klasör için ise;

Kod:

Private Sub CommandButton1_Click()
Set a = CreateObject("scripting.filesystemobject")
Set dic = CreateObject("scripting.dictionary")
dic.CompareMode = vbBinaryCompare
n = 1
   Set bm = CreateObject("shell.application")
    For Each cv In bm.Windows
sor = MsgBox(cv.document.folder.self.Path & vbCrLf & "Klasörü Açık" & vbCrLf & "Burada dosyalar sayılsınmı?", vbYesNo)
If sor = vbYes Then
For Each dosya In a.GetFolder(cv.document.folder.self.Path).Files
If a.GetExtensionName(dosya.Name) = LCase(Trim(TextBox1)) And InStr(1, dosya.Name, "$", vbTextCompare) = 0 Then
say = say + 1
End If
Next
On Error Resume Next
dic.Add n, cv.document.folder.self.Path
geri:
h = dic.Count
For j = n To h
Set klasor = a.GetFolder(dic(j))
If klasor.Subfolders.Count > 0 Then
For Each alt In klasor.Subfolders
For Each dosya In alt.Files
If a.GetExtensionName(dosya.Name) = LCase(Trim(TextBox1)) And InStr(1, dosya.Name, "$", vbTextCompare) = 0 Then
say = say + 1

End If
Next
dic.Add dic.Count + 1, alt
Next: End If: Next
If h < dic.Count Then
n = h + 1: Set klasor = Nothing:
GoTo geri: End If
End If

Next
MsgBox say
End Sub

Aşağıdaki kodlardada Halit bey in yaptığı gibi klasör seçerek;

Kod:

Private Sub CommandButton1_Click()
Set a = CreateObject("scripting.filesystemobject")
Set dic = CreateObject("scripting.dictionary")
dic.CompareMode = vbBinaryCompare
n = 1
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Klasor Is Nothing Then Exit Sub
Kaynak = Klasor.self.Path


For Each dosya In a.GetFolder(Kaynak).Files
If a.GetExtensionName(dosya.Name) = LCase(Trim(TextBox1)) And InStr(1, dosya.Name, "$", vbTextCompare) = 0 Then
say = say + 1
End If
Next
dic.Add n, Kaynak
geri:
h = dic.Count
For j = n To h
Set Klasor = a.GetFolder(dic(j))
 If Klasor.Subfolders.Count > 0 Then
For Each alt In Klasor.Subfolders
For Each dosya In alt.Files
If a.GetExtensionName(dosya.Name) = LCase(Trim(TextBox1)) And InStr(1, dosya.Name, "$", vbTextCompare) = 0 Then
say = say + 1

End If
Next
dic.Add dic.Count + 1, alt
Next: End If: Next
If h < dic.Count Then
n = h + 1: Set Klasor = Nothing:
GoTo geri: End If
MsgBox say
End Sub

Korhan Ayhan · 30 Aralık 2018

Alternatif,

Textbox nesnesine PDF yazıp butona tıklayın.

Kod:

Private Sub CommandButton1_Click()
    Say = 0
    Yol = ThisWorkbook.Path & "\"
    Dosya = Dir(Yol & "*." & TextBox1)
    While Dosya <> ""
        Say = Say + 1
        Dosya = Dir
    Wend

    Set Fso = CreateObject("Scripting.FileSystemObject")
10  Set Ana_Klasor = Fso.GetFolder(Yol)
    Set Alt_Klasorler = Ana_Klasor.SubFolders
    For Each Alt_Klasor In Alt_Klasorler
        Yol = Alt_Klasor.Path & "\"
        Dosya = Dir(Yol & "*." & TextBox1)
        While Dosya <> ""
            Say = Say + 1
            Dosya = Dir
        Wend
        GoTo 10
    Next
    
    MsgBox TextBox1 & " - uzantılı dosya sayısı " & Say & " adettir."
End Sub

k0081 · 30 Aralık 2018

PLİNT

Hocam yardımılarınız içi çok teşekkür ediyorum. göndermiş olduğunuz son iki kodu da denedim. sonuç aynı., eksik var.

halit3 · 30 Aralık 2018

Muhtemelen uzantısı büyük ve küçük olanlar var
Bu kodu bir dene

Kod:

Dim say
Sub pdfara()
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.self.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
say = 0
Liste (Kaynak)
MsgBox "Toplam " & say & " Dosya bulundu"
Set Klasor = Nothing
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub


Private Sub Liste(yol As String)
Dim fL As Object, f As Object
Set fL = CreateObject("Scripting.FileSystemObject")

For Each Dosya In fL.GetFolder(yol).Files
If LCase(fL.GetExtensionName(Dosya)) = LCase(Textbox1.Text) Then
say = say + 1
End If
Next

On Error GoTo sonraki
For Each f In fL.GetFolder(yol).subfolders
Liste (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub

k0081 · 30 Aralık 2018

Korhan Ayhan
Hocam kod için teşekkür ederim. Ama bu kod ile de tam sayıyı alamıyorum.

Konuyu biraz daha genişletmek gerekirse;

Deneme klasörü içinde 10 adet pdf var. deneme klasörüde bir başka dizin içinde.

klasör içinde klasör, klasör içinde dosya şeklinde dosyalar mevcut.

k0081 · 30 Aralık 2018

halit3

Hocam çok teşekkür ediyorum. Tamamdır. elinize yüreğinize sağlık.

halit3 · 30 Aralık 2018

k0081' Alıntı:
halit3

Hocam çok teşekkür ediyorum. Tamamdır. elinize yüreğinize sağlık.

Teşekkürler iyi çalışmalar

k0081 · 30 Aralık 2018

halit3' Alıntı:
Teşekkürler iyi çalışmalar

Hocam hazır alt klasörler kod içindeyken klasör sayılarınıda bir değişkene alabilirmiyiz _?

halit3 · 30 Aralık 2018

k0081' Alıntı:
Hocam hazır alt klasörler kod içindeyken klasör sayılarınıda bir değişkene alabilirmiyiz _?

kod:

Rich (BB code):

Dim say
Dim say2
Sub pdfara()
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.self.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
say = 0
Liste (Kaynak)
MsgBox "Toplam " & say & " Dosya bulundu"
MsgBox "Toplam " & say2 & " klasör bulundu"
Set Klasor = Nothing
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub


Private Sub Liste(yol As String)
Dim fL As Object, f As Object
Set fL = CreateObject("Scripting.FileSystemObject")

say2 = say2 + 1
For Each Dosya In fL.GetFolder(yol).Files
If LCase(fL.GetExtensionName(Dosya)) = LCase(Textbox1.Text) Then
say = say + 1
End If
Next

On Error GoTo sonraki
For Each f In fL.GetFolder(yol).subfolders
Liste (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub

k0081 · 30 Aralık 2018

Çok Teşekkür ederim Halit hocam. Tamamdır..

halit3 · 30 Aralık 2018

Bu kodda dosyaların boyutunu veriyor.

Kod:

Dim say1
Dim say2
Dim say3


Sub pdfara()
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.self.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
say1 = 0
say2 = 0
say3 = 0

Liste (Kaynak)
MsgBox "Toplam " & say1 & " Dosya bulundu"
MsgBox "Toplam " & say2 & " klasör bulundu"
MsgBox "Toplam " & say3 & " bayt"
MsgBox "Toplam " & Val(Round(say3 / 1048, 3) * 1) & " MB"


Set Klasor = Nothing
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub


Private Sub Liste(yol As String)
Dim fL As Object, f As Object
Set fL = CreateObject("Scripting.FileSystemObject")

say2 = say2 + 1
For Each Dosya In fL.GetFolder(yol).Files
If LCase(fL.GetExtensionName(Dosya)) = LCase(Textbox1.Text) Then
say3 = CDbl(say3) + FileLen(Dosya) / 1000

say1 = say1 + 1
End If
Next

On Error GoTo sonraki
For Each f In fL.GetFolder(yol).SubFolders
Liste (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub

Korhan Ayhan · 30 Aralık 2018

Merhaba,

Ben denemelerimde olumlu sonuç almıştım.

Sizde deneyiniz.

Klasördeki excel dosyasını çalıştırıp deneyiniz.

http://s3.dosya.tc/server18/9hs0wi/TEST.rar.html

Çözüldü Uzantı sayısı bulmak

k0081

PLİNT

k0081

halit3

Uzman

PLİNT

k0081

PLİNT

k0081

PLİNT

Korhan Ayhan

Administrator

k0081

halit3

Uzman

k0081

k0081

halit3

Uzman

k0081

halit3

Uzman

k0081

halit3

Uzman

Korhan Ayhan

Administrator

Ekli dosyalar