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