• DİKKAT

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

Kapalı Dosyadan Koşullu Veri Çekme

M

metin_0606

Katılım
1 Ağustos 2019
Mesajlar
839
Excel Vers. ve Dili
Türkçe excel 2016
İngilizce excel 2016
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)
 

Ekli dosyalar

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

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

C++: 
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 Ayhan' Alıntı:
Deneyiniz.

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

C++: 
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
Genişletmek için tıkla ...
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
 

Ekli dosyalar

  • Adsız.png
    Adsız.png
    131.1 KB · Görüntüleme: 11
Korhan Ayhan' Alıntı:
Deneyiniz.

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

C++: 
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
Genişletmek için tıkla ...
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' Alıntı:
Bende bahsettiğiniz pencere açılmıyor. Neyse siz zaten halletmişsiniz.
Genişletmek için tıkla ...
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
 
INDEX ile başlayan satırda değişiklik yapmalısınız.
 
Korhan Ayhan' Alıntı:
Deneyiniz.

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

C++: 
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
Genişletmek için tıkla ...
Ü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]"
 
Sanırım A2 de tarih var.
[A2] yazan yeri Format ([A2], "dd.mm.yyyy") şeklinde deneyin.
 
Dosya adı ve uzantısı doğrumu?Bir kontrol ediniz.
 
Orion1' Alıntı:
Dosya adı ve uzantısı doğrumu?Bir kontrol ediniz.
Genişletmek için tıkla ...
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ı
 
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.
 
Korhan Ayhan' Alıntı:
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.
Genişletmek için tıkla ...
teşekkür ederim Korhan Ayhan üstadım, sağlıcakla kalın
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst