Kapalı Dosyadan Koşullu Veri Çekme

[metin_0606]

Değerli Forum üyeleri Açık kitap isimli çalışma kitabımın B sütununda yazılı olan TC kimlik numaralarını Kapalı kitapta bulup buradaki ilgili TC kimlik numaralarına ait tarihleri Açık kitaptaki TC kimlik numaralarının karşısına Tarih2 sütununa getirip, Tarih 1 ve Tarih 2 sütunlarındaki tarihlerin farklarınıda"Sonuç" sütununa yazdırmak istiyorum. Elimde bu işlemi gören makro var ancak satır sayısı 4000 civarı olunca 4 dk işlemi bitiriyor. Bu konuda yardımlarınız için şimdiden teşekkürler NOT: Her iki dosyada masaüstün de bulunmakta olup Kapalı kitaptaki tarih formatları ilgili kurum sitesinin listesinde o şekilde gelmektedir.(tarih ve saat)

 

[Korhan Ayhan]

Tarihlerin farkı alınırken hangi tarihten hangi tarih çıkarılacak?

 

[metin_0606]

Tarihlerin farkı alınırken hangi tarihten hangi tarih çıkarılacak?

Tarih 1 den tarih 2 çıkarılacak Korhan hocam

 

[Korhan Ayhan]

Deneyiniz.

İşlem bende 1 saniyenin altında tamamlanıyor.

Option Explicit

Sub Kapali_Dosyadan_Veri_Al()
    Dim Yol As String, Dosya_Adi As String, Sayfa_Adi As String
    Dim S1 As Worksheet, X As Long, Son As Long, Zaman As Double
    
    Zaman = Timer
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    
    Yol = ThisWorkbook.Path & Application.PathSeparator
    Dosya_Adi = "[KAPALI KİTAP.xlsx]"
    Sayfa_Adi = "Sheet1"
    
    Set S1 = Sheets("ANA SAYFA")
    
    S1.Range("F2:G" & S1.Rows.Count).ClearContents
    
    Son = S1.Cells(S1.Rows.Count, 2).End(3).Row
    
    With S1.Range("F2:F" & Son)
        .Formula = "=INDEX('" & Yol & Dosya_Adi & Sayfa_Adi & "'!E:E,MATCH(B2,'" & Yol & Dosya_Adi & Sayfa_Adi & "'!B:B,0))"
        .Value = .Value
    End With
    
    With S1.Range("G2:G" & Son)
        .Formula = "=E2-F2"
        .Value = .Value
    End With
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    
    MsgBox "İşleminiz tamamlanmıştır." & vbCr & vbCr & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

 

[metin_0606]

Deneyiniz.

İşlem bende 1 saniyenin altında tamamlanıyor.

Option Explicit

Sub Kapali_Dosyadan_Veri_Al()
    Dim Yol As String, Dosya_Adi As String, Sayfa_Adi As String
    Dim S1 As Worksheet, X As Long, Son As Long, Zaman As Double
   
    Zaman = Timer
   
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
   
    Yol = ThisWorkbook.Path & Application.PathSeparator
    Dosya_Adi = "[KAPALI KİTAP.xlsx]"
    Sayfa_Adi = "Sheet1"
   
    Set S1 = Sheets("ANA SAYFA")
   
    S1.Range("F2:G" & S1.Rows.Count).ClearContents
   
    Son = S1.Cells(S1.Rows.Count, 2).End(3).Row
   
    With S1.Range("F2:F" & Son)
        .Formula = "=INDEX('" & Yol & Dosya_Adi & Sayfa_Adi & "'!E:E,MATCH(B2,'" & Yol & Dosya_Adi & Sayfa_Adi & "'!B:B,0))"
        .Value = .Value
    End With
   
    With S1.Range("G2:G" & Son)
        .Formula = "=E2-F2"
        .Value = .Value
    End With
   
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
   
    MsgBox "İşleminiz tamamlanmıştır." & vbCr & vbCr & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

Korhan hocam kodu örnek dosyada uyguladım gerçekten 2 sn gibi bir sürede verileri getirdi. Orjinal dosyama uyguladığımda ise Ekran görüntüsünü paylaştığım pencereyi açıyor. Ben açılan pencereye iptal yada çarpıdan kapattığım zaman verileri yine 2 sn getirtiyor. Pencerenin açılmasının nedeni ne olabilir acaba

 

[metin_0606]

Deneyiniz.

İşlem bende 1 saniyenin altında tamamlanıyor.

Option Explicit

Sub Kapali_Dosyadan_Veri_Al()
    Dim Yol As String, Dosya_Adi As String, Sayfa_Adi As String
    Dim S1 As Worksheet, X As Long, Son As Long, Zaman As Double
   
    Zaman = Timer
   
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
   
    Yol = ThisWorkbook.Path & Application.PathSeparator
    Dosya_Adi = "[KAPALI KİTAP.xlsx]"
    Sayfa_Adi = "Sheet1"
   
    Set S1 = Sheets("ANA SAYFA")
   
    S1.Range("F2:G" & S1.Rows.Count).ClearContents
   
    Son = S1.Cells(S1.Rows.Count, 2).End(3).Row
   
    With S1.Range("F2:F" & Son)
        .Formula = "=INDEX('" & Yol & Dosya_Adi & Sayfa_Adi & "'!E:E,MATCH(B2,'" & Yol & Dosya_Adi & Sayfa_Adi & "'!B:B,0))"
        .Value = .Value
    End With
   
    With S1.Range("G2:G" & Son)
        .Formula = "=E2-F2"
        .Value = .Value
    End With
   
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
   
    MsgBox "İşleminiz tamamlanmıştır." & vbCr & vbCr & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

Korhan hocam bu kodu yazarak Application.DisplayAlerts = False pencerenin açılmasını engelledim. Kod gerçekten çok hızlı çok teşekkür ederim. Sağolasın

 

[Korhan Ayhan]

Bende bahsettiğiniz pencere açılmıyor. Neyse siz zaten halletmişsiniz.

 

[metin_0606]

Bende bahsettiğiniz pencere açılmıyor. Neyse siz zaten halletmişsiniz.

Tekrardan çok teşekkür ederim üstat saygılarımla

 

[metin_0606]

Bende bahsettiğiniz pencere açılmıyor. Neyse siz zaten halletmişsiniz.

Korhan hocam kapalı dosyadaki TC kimlik numarası B sütununda değilde C sütununda olsa tarihte E sütununda değil F sütununda olsa bu makroda nasıl bir değişiklik yapmak gerekir acaba

 

[Korhan Ayhan]

INDEX ile başlayan satırda değişiklik yapmalısınız.

 

[baydeniro]

Deneyiniz.

İşlem bende 1 saniyenin altında tamamlanıyor.

Option Explicit

Sub Kapali_Dosyadan_Veri_Al()
    Dim Yol As String, Dosya_Adi As String, Sayfa_Adi As String
    Dim S1 As Worksheet, X As Long, Son As Long, Zaman As Double
   
    Zaman = Timer
   
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
   
    Yol = ThisWorkbook.Path & Application.PathSeparator
    Dosya_Adi = "[KAPALI KİTAP.xlsx]"
    Sayfa_Adi = "Sheet1"
   
    Set S1 = Sheets("ANA SAYFA")
   
    S1.Range("F2:G" & S1.Rows.Count).ClearContents
   
    Son = S1.Cells(S1.Rows.Count, 2).End(3).Row
   
    With S1.Range("F2:F" & Son)
        .Formula = "=INDEX('" & Yol & Dosya_Adi & Sayfa_Adi & "'!E:E,MATCH(B2,'" & Yol & Dosya_Adi & Sayfa_Adi & "'!B:B,0))"
        .Value = .Value
    End With
   
    With S1.Range("G2:G" & Son)
        .Formula = "=E2-F2"
        .Value = .Value
    End With
   
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
   
    MsgBox "İşleminiz tamamlanmıştır." & vbCr & vbCr & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

Üstad aklına sağlık harika bir kod olmuş. Şu kod satırının dosya adını her hücredeki aynı satırıda A sütununda bulunan dosya adından alması için kodu nasıl revize etmek lazım
bunun yerine > Dosya_Adi = "[KAPALI KİTAP.xlsx]" bunu yazdım ama olmadı > Dosya_Adi = "[" & [A2] & ".xlsm]"

 

[ÖmerFaruk]

Sanırım A2 de tarih var.
[A2] yazan yeri Format ([A2], "dd.mm.yyyy") şeklinde deneyin.

 

[baydeniro]

Sanırım A2 de tarih var.
[A2] yazan yeri Format ([A2], "dd.mm.yyyy") şeklinde deneyin.

ÖmerFaruk üstadım teşekkürler. Ama A2 de tarih değil, ilgili dosyanın adı yazılı

 

[Orion1]

Dosya adı ve uzantısı doğrumu?Bir kontrol ediniz.

 

[baydeniro]

Dosya adı ve uzantısı doğrumu?Bir kontrol ediniz.

Orion1 üstadım ilgine teşekkürler. Dosya adı ve uzantı doğru. Sorun şöyle;
- A2 hücresinde verinin çekileceği dosya adı var
- A3 hücresinde başa bir dosya adı var
Formülü F2:F3 alanına kopyalıyorum. A2 de sorun yok. Ama F3 hücresinde verinin çekileceği dosya tanımı A2 de kalıyor. beklentimiz A3 olması

 

[Korhan Ayhan]

Burada kullanılan kod yapısı tek dosya üzerine kurguludur. Siz birden fazla dosya için bir yapı kurmaya çalışıyorsanız dosya isimlerini döngüye almayı deneyebilirsiniz.

 

[baydeniro]

Burada kullanılan kod yapısı tek dosya üzerine kurguludur. Siz birden fazla dosya için bir yapı kurmaya çalışıyorsanız dosya isimlerini döngüye almayı deneyebilirsiniz.

teşekkür ederim Korhan Ayhan üstadım, sağlıcakla kalın