Makro revize

metin_0606 · 27 Şubat 2020

Kod:

Dim tcno As String

 

Sub dosyakontrol()

With Application

.Calculation = xlManual

.ScreenUpdating = False

.EnableEvents = False

End With

 

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 = ""

Cells(i, "E").Value = ""

 

If dosyavarmi("C:\FOTO\*.jpg", tcno) Then Cells(i, "B").Value = "VAR" Else Cells(i, "B").Value = "YOK"

If dosyavarmi("C:\NUFUS\*.pdf", tcno) Then Cells(i, "C").Value = "VAR" Else Cells(i, "C").Value = "YOK"

If dosyavarmi("C:\OGKK_PDF\*.pdf", tcno) Then Cells(i, "D").Value = "VAR" Else Cells(i, "D").Value = "YOK"

If dosyavarmi("C:\SGK YENI\*.pdf", tcno) Then Cells(i, "E").Value = "VAR" Else Cells(i, "E").Value = "YOK"

Next i

 

With Application

.Calculation = xlAutomatic

.ScreenUpdating = True

.EnableEvents = True

End With

 

 

MsgBox "işlem tamam"

End Sub

Bu makroyu Excel sayfamın A sütununa yazdığım yaklaşık 9000 satırlık TC kimlik numarasını baz alarak yine TC kimlik numarası ile isimlendirilmiş dört farklı klasörde tarama yaparak excelde ilgili başlıkların altına ve ilgili TC kimlik numaralarının karşılığına VAR veya YOK yazdırıyor um. Bu işlemi yaklaşık 2.5 dakikada gerçekleştiriyor. Bunu süre olarak kisaltmamiz mümkünmu acaba klsor içindeki veriler 12345678901 MERT KAYA ve 12345678923 formatında. Yardımlarınız için şimdiden teşekkürler

metin_0606 · 27 Şubat 2020

Makronun devami

Kod:

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

un devami

muzaffer.sm · 27 Şubat 2020

Buna benzer bir konu

Halit Hocanın yazmış olduğu bir kaç seçenekli kodu var. Sizin konu ile uyuşuyor.

Bu linki inceleyin.

Klasör içindeki dosya isimlerini tabloda yazılan isimlerle eşleştirmek

Merhabalar, forumda aradım ancak belki derdimi tam olarak ifade edemediğimden belki de yanlış kelimeleri aradığımdan dolayı bulamadım ve bu başlığı açmak zorunda kaldım. Sorunum şöyle: elimde bir klasör içinde TC Kimlik numaraları ile kaydedilmiş öğrenci resimleri var -yaklaşık 600 kadar- bir...

excel.web.tr

genesis_vision · 27 Şubat 2020

Bu şekilde dener misiniz?

Uyarı : Geliştirici >> Visual Basic >> Tools >> References >>Microsoft Scripting Runtime özelliğinin açık olması gerekir. Aksi takdirde kod çalışmayacaktır.

Kod:

Sub deneme()
Dim FSO As FileSystemObject: Set FSO = New FileSystemObject
Dim str As Long
Dim c, rng As Range
Dim xstart, xfinish As Date

xstart = Time

str = Cells(Rows.Count, 1).End(3).Row
Range("b2:e" & str).ClearContents

Set rng = Range("a2:a" & str)
For Each c In rng
    
    If FSO.FileExists("C:\FOTO\" & c.Value & ".jpg") Then
        c.Offset(, 1) = "Var"
    Else: c.Offset(, 1) = "yok"
    End If
    
    If FSO.FileExists("C:\NUFUS\" & c.Value & ".pdf") Then
        c.Offset(, 2) = "Var"
    Else: c.Offset(, 2) = "yok"
    End If
    
    If FSO.FileExists("C:\OGKK_PDF\" & c.Value & ".pdf") Then
        c.Offset(, 3) = "Var"
    Else: c.Offset(, 3) = "yok"
    End If
    
    If FSO.FileExists("C:\SGK YENI\" & c.Value & ".pdf") Then
        c.Offset(, 4) = "Var"
    Else: c.Offset(, 4) = "yok"
    End If
Next

xfinish = Time - xstart
MsgBox xfinish, vbInformation

End Sub

metin_0606 · 27 Şubat 2020

genesis_vision' Alıntı:

Bu şekilde dener misiniz?

Uyarı : Geliştirici >> Visual Basic >> Tools >> References >>Microsoft Scripting Runtime özelliğinin açık olması gerekir. Aksi takdirde kod çalışmayacaktır.

Kod:

Sub deneme()
Dim FSO As FileSystemObject: Set FSO = New FileSystemObject
Dim str As Long
Dim c, rng As Range
Dim xstart, xfinish As Date

xstart = Time

str = Cells(Rows.Count, 1).End(3).Row
Range("b2:e" & str).ClearContents

Set rng = Range("a2:a" & str)
For Each c In rng
   
    If FSO.FileExists("C:\FOTO\" & c.Value & ".jpg") Then
        c.Offset(, 1) = "Var"
    Else: c.Offset(, 1) = "yok"
    End If
   
    If FSO.FileExists("C:\NUFUS\" & c.Value & ".pdf") Then
        c.Offset(, 2) = "Var"
    Else: c.Offset(, 2) = "yok"
    End If
   
    If FSO.FileExists("C:\OGKK_PDF\" & c.Value & ".pdf") Then
        c.Offset(, 3) = "Var"
    Else: c.Offset(, 3) = "yok"
    End If
   
    If FSO.FileExists("C:\SGK YENI\" & c.Value & ".pdf") Then
        c.Offset(, 4) = "Var"
    Else: c.Offset(, 4) = "yok"
    End If
Next

xfinish = Time - xstart
MsgBox xfinish, vbInformation

End Sub

Sayın genesis süper 30 saniyede bitirdi çok teşekkür ederim

metin_0606 · 27 Şubat 2020

genesis_vision' Alıntı:

Bu şekilde dener misiniz?

Uyarı : Geliştirici >> Visual Basic >> Tools >> References >>Microsoft Scripting Runtime özelliğinin açık olması gerekir. Aksi takdirde kod çalışmayacaktır.

Kod:

Sub deneme()
Dim FSO As FileSystemObject: Set FSO = New FileSystemObject
Dim str As Long
Dim c, rng As Range
Dim xstart, xfinish As Date

xstart = Time

str = Cells(Rows.Count, 1).End(3).Row
Range("b2:e" & str).ClearContents

Set rng = Range("a2:a" & str)
For Each c In rng
   
    If FSO.FileExists("C:\FOTO\" & c.Value & ".jpg") Then
        c.Offset(, 1) = "Var"
    Else: c.Offset(, 1) = "yok"
    End If
   
    If FSO.FileExists("C:\NUFUS\" & c.Value & ".pdf") Then
        c.Offset(, 2) = "Var"
    Else: c.Offset(, 2) = "yok"
    End If
   
    If FSO.FileExists("C:\OGKK_PDF\" & c.Value & ".pdf") Then
        c.Offset(, 3) = "Var"
    Else: c.Offset(, 3) = "yok"
    End If
   
    If FSO.FileExists("C:\SGK YENI\" & c.Value & ".pdf") Then
        c.Offset(, 4) = "Var"
    Else: c.Offset(, 4) = "yok"
    End If
Next

xfinish = Time - xstart
MsgBox xfinish, vbInformation

End Sub

Sayın genesis sadece TC kimlik numaraları olan formattakileri buluyor ancak 12345678911 MEHMET UZUN.pdf ve benzer olan jpg uzantılı verileri görmüyor

metin_0606 · 27 Şubat 2020

metin_0606' Alıntı:
Sayın genesis sadece TC kimlik numaraları olan formattakileri buluyor ancak 12345678911 MEHMET UZUN.pdf ve benzer olan jpg uzantılı verileri görmüyor

Yani klasör içindeki TC kimlik numarasının yanında isim soy isim yazılı verileride görürse süper olacak

genesis_vision · 27 Şubat 2020

".jpg" yerine " *.jpg", ".pdf" yerine " *.pdf" yazarak deneyebilir misiniz?

Korhan Ayhan · 27 Şubat 2020

Alternatif;

Deneyiniz. Süre olarak avantaj sağlayabilir.

İÇERİR mantığı ile arama yapar.

C++:

Option Explicit

Sub TC_Kimlik_No_Kontrol()
    Dim Veri As Variant, Klasor As Variant, Uzanti As Variant, X As Long
    Dim Y As Byte, Son As Long, Dosya As String, Zaman As Double
  
    Zaman = Timer
  
    Application.ScreenUpdating = False
  
    Klasor = Array("C:\FOTO\", "C:\NUFUS\", "C:\OGKK_PDF\", "C:\SGK YENI\")
    Uzanti = Array(".jpg", ".pdf", ".pdf", ".pdf")
  
    Son = Cells(Rows.Count, 1).End(3).Row
    Veri = Range("A2:E" & Son).Value2
    Range("B2:E" & Rows.Count).ClearContents
  
    For X = LBound(Veri) To UBound(Veri)
        If Veri(X, 1) <> "" Then
            For Y = LBound(Klasor) To UBound(Klasor)
                Dosya = Dir(Klasor(Y) & "*" & Veri(X, 1) & "*" & Uzanti(Y))
                If Dosya <> "" Then
                    Veri(X, Y + 2) = "Var"
                Else
                    Veri(X, Y + 2) = "Yok"
                End If
            Next
        End If
    Next

    Range("A2").Resize(UBound(Veri, 1), UBound(Veri, 2)) = Veri

    Application.ScreenUpdating = True

    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

metin_0606 · 27 Şubat 2020

genesis_vision' Alıntı:
".jpg" yerine " *.jpg", ".pdf" yerine " *.pdf" yazarak deneyebilir misiniz?

Denedim ama olmadı maalesef sadece TC kimlik numarası yazanları buluyor

metin_0606 · 27 Şubat 2020

Korhan Ayhan' Alıntı:

Alternatif;

Deneyiniz. Süre olarak avantaj sağlayabilir.

C++:

Option Explicit

Sub TC_Kimlik_No_Kontrol()
    Dim Veri As Variant, Klasor As Variant, Uzanti As Variant, X As Long, Y As Byte, Son As Long, Dosya As String, Zaman As Double
   
    Zaman = Timer
   
    Application.ScreenUpdating = False
   
    Klasor = Array("C:\FOTO\", "C:\NUFUS\", "C:\OGKK_PDF\", "C:\SGK YENI\")
    Uzanti = Array(".jpg", ".pdf", ".pdf", ".pdf")
   
    Son = Cells(Rows.Count, 1).End(3).Row
    Veri = Range("A2:E" & Son).Value2
    Range("B2:E" & Rows.Count).ClearContents
   
    For X = LBound(Veri) To UBound(Veri)
        If Veri(X, 1) <> "" Then
            For Y = LBound(Klasor) To UBound(Klasor)
                Dosya = Dir(Klasor(Y) & "*" & Veri(X, 1) & "*" & Uzanti(Y))
                If Dosya <> "" Then
                    Veri(X, Y + 2) = "Var"
                Else
                    Veri(X, Y + 2) = "Yok"
                End If
            Next
        End If
    Next

    Range("A2").Resize(UBound(Veri, 1), UBound(Veri, 2)) = Veri

    Application.ScreenUpdating = True

    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

Korhan hocan yukarıda belirttiğim veri olarak her iki formattada sağlıklı çalıştı. 75 sn işlemi bitirdi. Paylaştığım makroya göre yarı zamanda yaptı. Teşekkür ederim

genesis_vision · 27 Şubat 2020

Deneyiniz.

Kod:

Sub deneme()
Dim str As Long
Dim c, rng As Range
Dim xstart, xfinish As Date

xstart = Time

str = Cells(Rows.Count, 1).End(3).Row
Range("b2:e" & str).ClearContents

Set rng = Range("a2:a" & str)

For Each c In rng
    If Dir("C:\FOTO\" & c.Value & "*.jpg") <> vbNullString Then
            c.Offset(, 1) = "Var"
    Else: c.Offset(, 1) = "Yok"
    End If

    If Dir("C:\NUFUS\" & c.Value & "*.pdf") <> vbNullString Then
        c.Offset(, 2) = "Var"
    Else: c.Offset(, 2) = "Yok"
    End If
 
    If Dir("C:\OGKK_PDF\" & c.Value & "*.pdf") <> vbNullString Then
        c.Offset(, 3) = "Var"
    Else: c.Offset(, 3) = "Yok"
    End If
 
    If Dir("C:\SGK YENI\" & c.Value & "*.pdf") <> vbNullString Then
        c.Offset(, 4) = "Var"
    Else: c.Offset(, 4) = "Yok"
    End If
Next

xfinish = Time - xstart
MsgBox xfinish, vbInformation

End Sub

Korhan Ayhan · 27 Şubat 2020

İlginç, ben 20.000 satırda denedim. Yaklaşık 5 saniyede bitirdi. Sanırım klasör içlerinde az dosya olduğundan bu sonucu aldım.

metin_0606 · 27 Şubat 2020

Korhan Ayhan' Alıntı:
İlginç, ben 20.000 satırda denedim. Yaklaşık 5 saniyede bitirdi. Sanırım klasör içlerinde az dosya olduğundan bu sonucu aldım.

benim dört klasörde 20 bine yakın veri var korhan bey

metin_0606 · 27 Şubat 2020

genesis_vision' Alıntı:

Deneyiniz.

Kod:

Sub deneme()
Dim str As Long
Dim c, rng As Range
Dim xstart, xfinish As Date

xstart = Time

str = Cells(Rows.Count, 1).End(3).Row
Range("b2:e" & str).ClearContents

Set rng = Range("a2:a" & str)

For Each c In rng
    If Dir("C:\FOTO\" & c.Value & "*.jpg") <> vbNullString Then
            c.Offset(, 1) = "Var"
    Else: c.Offset(, 1) = "Yok"
    End If

    If Dir("C:\NUFUS\" & c.Value & "*.pdf") <> vbNullString Then
        c.Offset(, 2) = "Var"
    Else: c.Offset(, 2) = "Yok"
    End If

    If Dir("C:\OGKK_PDF\" & c.Value & "*.pdf") <> vbNullString Then
        c.Offset(, 3) = "Var"
    Else: c.Offset(, 3) = "Yok"
    End If

    If Dir("C:\SGK YENI\" & c.Value & "*.pdf") <> vbNullString Then
        c.Offset(, 4) = "Var"
    Else: c.Offset(, 4) = "Yok"
    End If
Next

xfinish = Time - xstart
MsgBox xfinish, vbInformation

End Sub

Sayın genesis şimdi oldu 37 sn de işlemi bitirdi teşekkür ederim çok sağolun

genesis_vision · 27 Şubat 2020

@metin

metin_0606' Alıntı:
Sayın genesis şimdi oldu 37 sn de işlemi bitirdi teşekkür ederim çok sağolun

Rica ederim güle güle kullanın.

tahsinanarat · 27 Şubat 2020

Sn. @genesis_vision 12 nolu mesajınızdaki kod güzel çalışıyor,bende 4Bin satırlık veriyi 4 sn. de bitiriyor. Elinize sağlık, Bu kodda var yazan yerlere dosya adını yazdırıp, link atamak istersek kodda nasıl bir değişikliği gidilebilir. Teşekkürler.

genesis_vision · 27 Şubat 2020

tahsinanarat' Alıntı:
Sn. @genesis_vision 12 nolu mesajınızdaki kod güzel çalışıyor,bende 4Bin satırlık veriyi 4 sn. de bitiriyor. Elinize sağlık, Bu kodda var yazan yerlere dosya adını yazdırıp, link atamak istersek kodda nasıl bir değişikliği gidilebilir. Teşekkürler.

Sayın @tahsinanarat fikir vermesi açısından aşağıdaki kodları deneyebilirsiniz. Umarım işinize yarar.

Kod:

Sub bagEkle()
Dim FD As FileDialog
Dim str As Long
Dim c, rng As Range
Dim xstart, xfinish As Date
Dim xPath As String


Set FD = Application.FileDialog(msoFileDialogFolderPicker)
    If FD.Show = -1 Then
        xPath = FD.SelectedItems(1)
    End If
    
Set FD = Nothing
If xPath = "" Then Exit Sub

xstart = Time

str = Cells(Rows.Count, 1).End(3).Row
Range("b2:e" & str).ClearContents

Set rng = Range("a2:a" & str)

For Each c In rng
    If Dir(xPath & "\" & c.Value & "*.jpg") <> vbNullString Then
         ActiveSheet.Hyperlinks.Add Anchor:=c.Offset(, 1), _
         Address:=xPath & "\" & c.Value & ".jpg", _
         TextToDisplay:=c.Text
    Else: c.Offset(, 1) = "Bulunamadı"
    End If
  
Next

xfinish = Time - xstart
MsgBox xfinish, vbInformation

End Sub

tahsinanarat · 27 Şubat 2020

Sn. @@genesis_vision gösterdiğiniz alaka için çok teşekkürler, bu başka bir projede kullanılabilir, bu kodda da yine bire bir eşleşme istiyor yani saadece tc kimlik numarası eşleyenleri getiriyor, 11991278023 TAHSİN ANARAT (ssg) gibi bir datayı olduğu gibi getirip link atamasını istemiştim, hatta 12.mesajınızda link atayarak dataları getirebilirse mükemmel olurdu. Teşekkürler

Korhan Ayhan · 28 Şubat 2020

Aşağıdaki kodu deneyiniz.

Daha iyi performans veriyor.

İLE BAŞLAR mantığı ile arama yapar.

Bir önceki önerim İÇERİR mantığı ile arama yaptığı için daha yavaş çalışıyordu. Aşağıdaki kod bende oldukça hızlı sonuç verdi. Yaklaşık 7 saniye sürdü.

TEST VERİSİ;
25.000 satır
4 Klasör + 25.000 Dosya

C++:

Option Explicit

Sub TC_Kimlik_No_Kontrol()
    Dim Veri As Variant, Klasor As Variant, Uzanti As Variant, X As Long
    Dim Y As Byte, Son As Long, Dosya As String, Zaman As Double
   
    Zaman = Timer
   
    Application.ScreenUpdating = False
   
    Klasor = Array("C:\FOTO\", "C:\NUFUS\", "C:\OGKK_PDF\", "C:\SGK YENI\")
    Uzanti = Array(".jpg", ".pdf", ".pdf", ".pdf")
   
    Son = Cells(Rows.Count, 1).End(3).Row
    Veri = Range("A2:E" & Son).Value2
    Range("B2:E" & Rows.Count).ClearContents
   
    For X = LBound(Veri) To UBound(Veri)
        If Veri(X, 1) <> "" Then
            For Y = LBound(Klasor) To UBound(Klasor)
                Dosya = Dir(Klasor(Y) & Veri(X, 1) & "*" & Uzanti(Y))
                If Dosya <> "" Then
                    Veri(X, Y + 2) = "Var"
                Else
                    Veri(X, Y + 2) = "Yok"
                End If
            Next
        End If
    Next

    Range("A2").Resize(UBound(Veri, 1), UBound(Veri, 2)) = Veri

    Application.ScreenUpdating = True

    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

Makro revize

metin_0606

metin_0606

muzaffer.sm

Klasör içindeki dosya isimlerini tabloda yazılan isimlerle eşleştirmek

genesis_vision

metin_0606

metin_0606

metin_0606

genesis_vision

Korhan Ayhan

Administrator

metin_0606

metin_0606

genesis_vision

Korhan Ayhan

Administrator

metin_0606

metin_0606

genesis_vision

tahsinanarat

genesis_vision

tahsinanarat

Korhan Ayhan

Administrator