alt klasörleri de aynı satırda toplam olarak sonuç alabilirmiyiz
Yukardaki yeri tam anlayamadım ne demek istediğinizi.Excelde sonuçları nasıl çıkacağını gösterebilirmisiniz satırlarda.
Ayrıca eğer accesste tabloda görmek istiyorsanız yaptığım kodlar insert into ile tabloya uyarlanabilir diye düşünüyorum.
Yani png ve jpg adetlerini bulduğumuza göre kodla sadece ilgili yerleri insert into ile aktarlır tabloya.
Yani excelde tam herşey biterse accese uygulanması kolay olur.Ve eklediğim kod uygun Access için.
Klasör İçindeki Fotografları Sayma
Hocam benim arşiv sistemin örnektekine benzer bişekilde onları seçerken zorluk yaşamayalım diye yazmıştım
dosya saydır - 3.rar
(Dosya Boyutu: 7,4 MB | İndirme Sayısı: 3)
Son Düzenleme: 10/04/2020, 00:56, Düzenleyen: akarayilan.
Eklediğiniz resimde Kls2* ve Kls5* eklemişsiniz.Sadece bu iki klasördemi aranacak tam anlayamıyorum.
Metin olarak alfabetik sıralatma ise metin ve sayı birleşik olduğğu için tam olmayacağını sanıyorum.
Metin olarak alfabetik sıralatma ise metin ve sayı birleşik olduğğu için tam olmayacağını sanıyorum.
Ayrıca mantık hatası olmuş A sütunu için.
yukardaki yerine alttaki olacak çünkü resim uzantısına gerek yok.Esasen A sütunada gerek yok ilk denemelerimden kalan birşey.Eğer köprü eklerseniz A sütununa o klasörü açar.
PHP Kod:
a = fso.GetAbsolutePathName(Fileler)
PHP Kod:
a = fso.GetParentFolderName(Fileler)
hayır üstadım benim saydırma yapacağım klasör çok fazla ve isimleri değişik başlangıçları sıralı olarak gidiyor sonuna eklediğim * farklı kelmeler veta sayılar içeriyor * onun için koydum saydırmak için iki farklı kombinasyon belirlenecek
Esas saydırmak istediğim klasör isimleri
Rp.2020-150 Evden hısızlık
Rp.2020-151 İşyerinden hırsızlık
.
.
.
.
.
.
.
Rp.2020-200 Yaralama
gibi bu sayı sürekli artıyor ben bunları aylık belirli dosyaları saydıracağım
ilgin için teşekkürler
Esas saydırmak istediğim klasör isimleri
Rp.2020-150 Evden hısızlık
Rp.2020-151 İşyerinden hırsızlık
.
.
.
.
.
.
.
Rp.2020-200 Yaralama
gibi bu sayı sürekli artıyor ben bunları aylık belirli dosyaları saydıracağım
ilgin için teşekkürler
Merhaba.
Tam olarak anladımmı bilemiyorum anladığım kadarıyla yaptım.
![[Resim: MTVlOTA2NWE1NmE1MTQ.gif]](http://flashresim.com/upload/MTVlOTA2NWE1NmE1MTQ.gif)
Kodlar altta.Eğer sonuçlar doğruysa Access dosyanızı yükleyin ona uyarlarız.
Tam olarak anladımmı bilemiyorum anladığım kadarıyla yaptım.
Kodlar altta.Eğer sonuçlar doğruysa Access dosyanızı yükleyin ona uyarlarız.
PHP Kod:
Const sayAd As String = "Sayfa1"
Dim say As Long
Dim arr
Sub AraNumaraVer1()
Dim AltDosyalar As Object
Dim Dosyalar As Object
Dim dosya As Object
Dim fso As Object
Dim DosyaAc As String
Sheets(sayAd).Range("H10:H" & Rows.Count).ClearContents
say = 0
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = ThisWorkbook.path & "\"
If .Show = -1 Then
DosyaAc = .SelectedItems(1)
Else
MsgBox "iptal edildi", vbExclamation, "iptal"
Exit Sub
End If
End With
ReDim arr(1 To 1, 1 To 1000000)
If DosyaAc <> "" Then
Set fso = CreateObject("Scripting.FileSystemObject")
Set Dosyalar = fso.Getfolder(DosyaAc)
ReDim arr(1 To 1, 1 To 1000000)
With Sheets(sayAd)
For Each dosya In Dosyalar.SubFolders
a = InStr(1, fso.GetBaseName(dosya), " ")
If a > 0 Then b = Mid(fso.GetBaseName(dosya), 1, a - 1)
c = Val(Mid(b, 4, Len(b)))
d = Val(Mid(Sayfa2.TextBox1.Value, 4, Len(Sayfa2.TextBox1.Value)))
e = Val(Mid(Sayfa2.TextBox2.Value, 4, Len(Sayfa2.TextBox2.Value)))
If c > e Then Exit For
If Val(Mid(b, 4, Len(b))) >= Val(Mid(Sayfa2.TextBox1.Value, 4, Len(Sayfa2.TextBox1.Value))) Then
Call DosyaAraAlt(dosya)
End If
Next
End With
MsgBox "Bitti", vbInformation, "Bitti"
Sheets(sayAd).Range("H10").Resize(UBound(arr, 2), 1).Value = Application.Transpose(arr)
End If
On Error Resume Next
Set fso = Nothing
Set Dosyalar = Nothing
Set dosya = Nothing
Erase arr
End Sub
Sub DosyaAraAlt(ByVal path As String)
Dim AltDosyalar As Object
Dim Dosyalar As Object
Dim dosya As Object
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set Dosyalar = fso.Getfolder(path)
With Sheets(sayAd)
For Each dosya In Dosyalar.SubFolders
say = say + 1
ReDim Preserve arr(1 To 1, 1 To say)
arr(1, say) = say & "- " & fso.GetBaseName(dosya)
Next
End With
For Each AltDosyalar In Dosyalar.SubFolders
Call DosyaAraAlt(AltDosyalar.path)
Next
On Error Resume Next
Set fso = Nothing
Set AltDosyalar = Nothing
Set Dosyalar = Nothing
Set Fileler = Nothing
End Sub
PHP Kod:
Dim say3 As Long
Dim yolAl As String 'Ana Klasor yol
Const SayfaAd As String = "Sayfa1"
Private Sub CommandButton1_Click()
With Sheets(SayfaAd)
.Range("A3:F" & Rows.Count).ClearContents
yolAl = ThisWorkbook.path & "\Arsiv\Kls3 Mustafa" 'Ana Klasor yol sadece burasi degisecek
Call DosyaAraAlt(yolAl, 1) '1 ana klasörler icin
Call DosyaAraAlt(yolAl, 2) '2 alt klasörler icin
End With
say3 = 0
say3 = Empty
End Sub
Sub DosyaAraAlt(ByVal path As String, alan As Byte)
Dim AltDosyalar As Object
Dim Dosyalar As Object
Dim Fileler As Object
Dim fso As Object
Dim say As Long, say1 As Long, say2 As Long, son As Long
Dim scr As Object
Dim arr
Set fso = CreateObject("Scripting.FileSystemObject")
Set arama = CreateObject("Scripting.Dictionary")
say = 0: say1 = 0: say2 = 0
Set Dosyalar = fso.Getfolder(path)
Application.ScreenUpdating = False
say = say + 1
say3 = say3 + 1
With Sheets(SayfaAd)
ReDim arr(1 To 4, 1 To 1)
For Each Fileler In Dosyalar.Files
If UCase(fso.GetExtensionName(Fileler)) = "JPG" Then say1 = say1 + 1
If UCase(fso.GetExtensionName(Fileler)) = "PNG" Then say2 = say2 + 1
a = fso.GetParentFolderName(Fileler)
b = fso.GetBaseName(path)
Next
If say1 > 0 Or say2 > 0 Then
arr(1, say) = a
arr(2, say) = b
arr(3, 1) = say1
arr(4, 1) = say2
If alan = 1 Then
.Range("A3").Resize(1, 4) = Application.Transpose(arr)
GoTo var
ElseIf alan = 2 Then
If say3 = 2 Then GoTo var2
son = .Cells(Rows.Count, 1).End(3).Row + 1
.Range("A" & son).Value = a
.Range("B" & son).Value = b
.Range("E" & son).Value = say1
.Range("F" & son).Value = say2
End If
End If
var2:
For Each AltDosyalar In Dosyalar.SubFolders
Call DosyaAraAlt(AltDosyalar.path, 2)
Next
End With
var:
Application.ScreenUpdating = True
On Error Resume Next
Set fso = Nothing
Set AltDosyalar = Nothing
Set Dosyalar = Nothing
Set Fileler = Nothing
Set scr = Nothing
Erase arr
End Sub
dosya saydır - 5.rar
(Dosya Boyutu: 6,32 MB | İndirme Sayısı: 1)
Konuyu Okuyanlar: 1 Ziyaretçi
