• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Klasör içinde veri tarama

M

metin_0606

Katılım
1 Ağustos 2019
Mesajlar
839
Excel Vers. ve Dili
Türkçe excel 2016
İngilizce excel 2016
C:\ sürücüsünün içerisinde FOTO ,NUFUS CUZDANİ,OGKK isminde 3 adet klasörüm var. Bu klasör içindeki verilerin isimlendirmeleri 12345678901 MERT ATAK veya sadece 12344678901 şeklindedir. Benim yapmak istediğim Excel calisma sayfasının A sütununa yazdığım TC KİMLİK numaraları doğrultusunda bu belirttiğim üç klasörde tarama yaparak ilgili başlıkların altına bu verilerin olup olmadığı yönünde VAR yada YOK yazmasını istiyorum. Örnek dosya ektedir. Fotolar JPG uzantılı diğer veriler PDF uzantilidir. Yardımlarınız için şimdiden teşekkürler. Saygılar
 

Ekli dosyalar

Sayfanın kod bölümüne ekleyiniz.

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)  
  If Intersect(Target, Range("A2:A100000")) Is Nothing Then Exit Sub
  If Target.Value = "" Then
     Cells(Target.Row, "B").Value = ""
     Cells(Target.Row, "C").Value = ""
     Cells(Target.Row, "D").Value = ""
  Else
     If dosyavarmi("C:\foto\" & Target.Value & ".jpg") Then Cells(Target.Row, "B").Value = "VAR" Else Cells(Target.Row, "B").Value = "YOK"
     If dosyavarmi("C:\nufus cuzdani\" & Target.Value & ".pdf") Then Cells(Target.Row, "C").Value = "VAR" Else Cells(Target.Row, "C").Value = "YOK"
     If dosyavarmi("C:\ogkk\" & Target.Value & ".pdf") Then Cells(Target.Row, "D").Value = "VAR" Else Cells(Target.Row, "D").Value = "YOK"
  End If
End Sub

Function dosyavarmi(dosya)
  Dim ds, a
  Set ds = CreateObject("Scripting.FileSystemObject")
  a = ds.FileExists(dosya)
  If a = True Then
    dosyavarmi = True
  Else
    dosyavarmi = False
  End If
End Function
 
asri' Alıntı:
Sayfanın kod bölümüne ekleyiniz.

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range) 
  If Intersect(Target, Range("A2:A100000")) Is Nothing Then Exit Sub
  If Target.Value = "" Then
     Cells(Target.Row, "B").Value = ""
     Cells(Target.Row, "C").Value = ""
     Cells(Target.Row, "D").Value = ""
  Else
     If dosyavarmi("C:\foto\" & Target.Value & ".jpg") Then Cells(Target.Row, "B").Value = "VAR" Else Cells(Target.Row, "B").Value = "YOK"
     If dosyavarmi("C:\nufus cuzdani\" & Target.Value & ".pdf") Then Cells(Target.Row, "C").Value = "VAR" Else Cells(Target.Row, "C").Value = "YOK"
     If dosyavarmi("C:\ogkk\" & Target.Value & ".pdf") Then Cells(Target.Row, "D").Value = "VAR" Else Cells(Target.Row, "D").Value = "YOK"
  End If
End Sub

Function dosyavarmi(dosya)
  Dim ds, a
  Set ds = CreateObject("Scripting.FileSystemObject")
  a = ds.FileExists(dosya)
  If a = True Then
    dosyavarmi = True
  Else
    dosyavarmi = False
  End If
End Function
Genişletmek için tıkla ...
Asri bey TC kimlik numaralarını tek tek ilgili hücreye yapıştırdığımda kod çalışıyor ancak 8000 adet TC kimlik numarasını toplu halde kopyaladığımda hata veriyor bunu nasıl çözebiliriz
 
ilk 2 satırı aşağıdaki şekilde değiştirip deneyin.

Private Sub Worksheet_Change(ByVal Target As Range)
if selection.count>1 then exit sub
 
metin_0606' Alıntı:
Denedim ama herhangi bir sonuç vermedi asri bey
Genişletmek için tıkla ...

Program tc kimlik numaralarının anlık girilmesi mantığı ile yazıldı.
Yani her hücreye giriş yaptığınızda kontrol sağlar.

Siz daha farklı olarak hepsi hazır bir buton ile kontrol etsin istiyorsunuz sanırım.

A2 ve sonrasında F2 ve enter yaparak dener misiniz. Sonuç veriyor mu?
 
asri' Alıntı:
Program tc kimlik numaralarının anlık girilmesi mantığı ile yazıldı.
Yani her hücreye giriş yaptığınızda kontrol sağlar.

Siz daha farklı olarak hepsi hazır bir buton ile kontrol etsin istiyorsunuz sanırım.

A2 ve sonrasında F2 ve enter yaparak dener misiniz. Sonuç veriyor mu?
Genişletmek için tıkla ...
evet tek tek f2 enter yapınca sonuç veriyor veri sayım az olsa dediğiniz çözüm olabilir ancak veri sayım çok maalesef bu makroyu module uyarlamak mümkünmü acaba
 
Dosyakontrol prosedürünü bir butona bağlayıp deneyiniz.

Kod: 
Sub dosyakontrol()
  sonsatir = Cells(Rows.Count, "A").End(3).Row
  For i = 2 To sonsatir
    tcno = Cells(i, "A").Value
    If tcno = "" Then
       Cells(i, "B").Value = ""
       Cells(i, "C").Value = ""
       Cells(i, "D").Value = ""
    Else
       If dosyavarmi("C:\foto\" & tcno & ".jpg") Then Cells(i, "B").Value = "VAR" Else Cells(i, "B").Value = "YOK"
       If dosyavarmi("C:\nufus cuzdani\" & tcno & ".pdf") Then Cells(i, "C").Value = "VAR" Else Cells(i, "C").Value = "YOK"
       If dosyavarmi("C:\ogkk\" & tcno & ".pdf") Then Cells(i, "D").Value = "VAR" Else Cells(i, "D").Value = "YOK"
    End If
  Next i
  
End Sub

Function dosyavarmi(dosya)
  Dim ds, a
  Set ds = CreateObject("Scripting.FileSystemObject")
  a = ds.FileExists(dosya)
  If a = True Then
    dosyavarmi = True
  Else
    dosyavarmi = False
  End If
End Function
 
asri' Alıntı:
Dosyakontrol prosedürünü bir butona bağlayıp deneyiniz.

Kod: 
Sub dosyakontrol()
  sonsatir = Cells(Rows.Count, "A").End(3).Row
  For i = 2 To sonsatir
    tcno = Cells(i, "A").Value
    If tcno = "" Then
       Cells(i, "B").Value = ""
       Cells(i, "C").Value = ""
       Cells(i, "D").Value = ""
    Else
       If dosyavarmi("C:\foto\" & tcno & ".jpg") Then Cells(i, "B").Value = "VAR" Else Cells(i, "B").Value = "YOK"
       If dosyavarmi("C:\nufus cuzdani\" & tcno & ".pdf") Then Cells(i, "C").Value = "VAR" Else Cells(i, "C").Value = "YOK"
       If dosyavarmi("C:\ogkk\" & tcno & ".pdf") Then Cells(i, "D").Value = "VAR" Else Cells(i, "D").Value = "YOK"
    End If
  Next i
 
End Sub

Function dosyavarmi(dosya)
  Dim ds, a
  Set ds = CreateObject("Scripting.FileSystemObject")
  a = ds.FileExists(dosya)
  If a = True Then
    dosyavarmi = True
  Else
    dosyavarmi = False
  End If
End Function
Genişletmek için tıkla ...
Şimdi oldu asri hocam yalnız şöyle bir sıkıntı oldu yukarıda belirttiğim gibi verilerin bir kısmı sadece TC kimlik numaralı isimlendirilmiş bir kısmıda örneğin 12345678911 MERT ATAKAN.pdf yada 12345678911 MERT ATAKAN.jpg olarak isimlendirilmiş. Sadece TC kimlik numaralı isimlendirimiş verileri buluyor ancak hem Tc kimlik numaralı hemde isim soy isimli isimlendirilmiş verileri bulmuyor
 
metin_0606' Alıntı:
Şimdi oldu asri hocam yalnız şöyle bir sıkıntı oldu yukarıda belirttiğim gibi verilerin bir kısmı sadece TC kimlik numaralı isimlendirilmiş bir kısmıda örneğin 12345678911 MERT ATAKAN.pdf yada 12345678911 MERT ATAKAN.jpg olarak isimlendirilmiş. Sadece TC kimlik numaralı isimlendirimiş verileri buluyor ancak hem Tc kimlik numaralı hemde isim soy isimli isimlendirilmiş verileri bulmuyor
Genişletmek için tıkla ...

Excel dosyasında adı soyadı kolonu ekleyebiliyor musunuz?
Ekleyemiyorsanız biraz uzun yollu bir işlem olacak.
 
asri' Alıntı:
Excel dosyasında adı soyadı kolonu ekleyebiliyor musunuz?
Ekleyemiyorsanız biraz uzun yollu bir işlem olacak.
Genişletmek için tıkla ...
TC kimlik numarasını yanına isim soy isim yazdığımda bu seferde sadece TC kimlik numaralı olanları görmüyor
 
Aşağıdaki şekilde deneyiniz.

Makro ilk boşluğa kadar tcno var sayar. Boşluk yok ise "." ya kadar tcno var sayar.


Kod: 
Dim tcno As String

Sub dosyakontrol()
  sonsatir = Cells(Rows.Count, "A").End(3).Row
  For i = 2 To sonsatir
    tcno = Cells(i, "A").Value
    Cells(i, "B").Value = ""
    Cells(i, "C").Value = ""
    Cells(i, "D").Value = ""

    If dosyavarmi("C:\foto\*.jpg", tcno) Then Cells(i, "B").Value = "VAR" Else Cells(i, "B").Value = "YOK"
    If dosyavarmi("C:\nufus cuzdani\*.pdf", tcno) Then Cells(i, "C").Value = "VAR" Else Cells(i, "C").Value = "YOK"
    If dosyavarmi("C:\ogkk\*.pdf", tcno) Then Cells(i, "D").Value = "VAR" Else Cells(i, "D").Value = "YOK"
  Next i
 
End Sub

Function dosyavarmi(yol, tcnostr As String)
  dosya = Dir(yol)
  Do While dosya <> ""
    If InStr(dosya, " ") > 0 Then
       isim = Mid(dosya, 1, InStr(dosya, " ") - 1)
    ElseIf InStr(dosya, ".") > 0 Then
       isim = Mid(dosya, 1, InStr(dosya, ".") - 1)
    End If
    If isim = tcnostr Then
       dosyavarmi = True
       Exit Function
    End If
    dosya = Dir
  Loop
  dosyavarmi = False
End Function
 
asri' Alıntı:
Aşağıdaki şekilde deneyiniz.

Makro ilk boşluğa kadar tcno var sayar. Boşluk yok ise "." ya kadar tcno var sayar.


Kod: 
Dim tcno As String

Sub dosyakontrol()
  sonsatir = Cells(Rows.Count, "A").End(3).Row
  For i = 2 To sonsatir
    tcno = Cells(i, "A").Value
    Cells(i, "B").Value = ""
    Cells(i, "C").Value = ""
    Cells(i, "D").Value = ""

    If dosyavarmi("C:\foto\*.jpg", tcno) Then Cells(i, "B").Value = "VAR" Else Cells(i, "B").Value = "YOK"
    If dosyavarmi("C:\nufus cuzdani\*.pdf", tcno) Then Cells(i, "C").Value = "VAR" Else Cells(i, "C").Value = "YOK"
    If dosyavarmi("C:\ogkk\*.pdf", tcno) Then Cells(i, "D").Value = "VAR" Else Cells(i, "D").Value = "YOK"
  Next i

End Sub

Function dosyavarmi(yol, tcnostr As String)
  dosya = Dir(yol)
  Do While dosya <> ""
    If InStr(dosya, " ") > 0 Then
       isim = Mid(dosya, 1, InStr(dosya, " ") - 1)
    ElseIf InStr(dosya, ".") > 0 Then
       isim = Mid(dosya, 1, InStr(dosya, ".") - 1)
    End If
    If isim = tcnostr Then
       dosyavarmi = True
       Exit Function
    End If
    dosya = Dir
  Loop
  dosyavarmi = False
End Function
Genişletmek için tıkla ...
Çok teşekkür ederim asri hocam şimdi oldu Hakkını helal et yordum sizi zihninize sağlık
 
Helal olsun. Sonuç almış olmak yeterli.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst