DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Sub Klasorden_dosyaları_bul()
'Application.ScreenUpdating = False
'Application.DisplayAlerts = False
yol = ThisWorkbook.Path
ReDim dosyalar(65000)
Dim fs As Object, t As Long
Set fs = CreateObject("Scripting.FileSystemObject")
say = 0
For Each Dosya In fs.GetFolder(yol).Files
bulunan = fs.GetBaseName(Dosya.Name)
say = say + 1
dosyalar(say) = bulunan
Next
For t = 5 To Cells(Rows.Count, "D").End(3).Row
aranan = Cells(t, "D").Value
For i = 1 To say
deg = dosyalar(i)
If deg Like "*" & Trim(aranan) & "*" = True Then
Cells(t, "P").Value = "VAR"
GoTo atla
End If
Next i
Cells(t, "P").Value = "YOK"
atla:
Next t
MsgBox "işlem tamam"
End Sub
Sub Klasorden_dosyaları_bul()
With Application
.Calculation = xlManual
.ScreenUpdating = False
.EnableEvents = False
End With
yol = ThisWorkbook.Path
ReDim dosyalar(65000)
Dim fs As Object, t As Long
Set fs = CreateObject("Scripting.FileSystemObject")
say = 0
For Each dosya In fs.GetFolder(yol).Files
If LCase(fs.GetExtensionName(dosya)) = "pdf" Then
say = say + 1
dosyalar(say) = fs.GetBaseName(dosya.Name)
End If
Next
For t = 5 To Cells(Rows.Count, "D").End(3).Row
aranan = Cells(t, "D").Value
For i = 1 To say
deg = dosyalar(i)
If deg Like "*" & Trim(aranan) & "*" = True Then
Cells(t, "P").Value = "VAR"
GoTo atla
End If
Next i
Cells(t, "P").Value = "YOK"
atla:
Next t
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlAutomatic
End With
MsgBox "işlem tamam"
End Sub
Dim dosyalar(65000)
Dim say
Sub Klasorden_dosyaları_bul()
With Application
.Calculation = xlManual
.ScreenUpdating = False
.EnableEvents = False
End With
say = 0
Liste (ThisWorkbook.Path)
For t = 5 To Cells(Rows.Count, "D").End(3).Row
aranan = Cells(t, "D").Value
For i = 1 To say
deg = dosyalar(i)
If deg Like "*" & Trim(aranan) & "*" = True Then
Cells(t, "P").Value = "VAR"
GoTo atla
End If
Next i
Cells(t, "P").Value = "YOK"
atla:
Next t
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlAutomatic
End With
MsgBox "işlem tamam"
End Sub
Private Sub Liste(yol As String)
Dim fs As Object, f As Object, t As Long
Set fs = CreateObject("Scripting.FileSystemObject")
For Each dosya In fs.GetFolder(yol).Files
If LCase(fs.GetExtensionName(dosya)) = "pdf" Then
say = say + 1
dosyalar(say) = fs.GetBaseName(dosya.Name)
End If
Next
On Error GoTo sonraki
For Each f In fs.GetFolder(yol).subfolders
Liste (f.Path)
sonraki:
Next
Set fs = Nothing
End Sub