Sayfalar Arası Arama ve Aktarma

[MrExcelMr]

Merhaba;

Forumu bir arkadaşımın whatapps grubumuz üzerinden paylaşması sonrası üye oldum. Öncelikle forumda yer alan herkese selamlar.

Ekte mevcut dosyamda bir çalışma yapmak istiyorum. Satır sayısılarının her geçen gün artması sebebiyle formüller ihtiyacımı karşılamamaya başladı. Sürekli bilgisayarda kiltlemeler, ekranın donması ...v.b sıkıntılar doğurmaya başlamıştır. Siz değerli forumdaşlardan yardımcı olmanızı talep ediyorum.

Konu:
Bir çalışma kitabında 2 adet sayfa bulunmaktadır. Verilerin bulunduğu (Sheet1) ve Arama yaptığım ve aktarmasını yaptığım (Sheet2) sayfalarımdan oluşmaktadır.

Sheet1 sayfasının C sütunundaki verileri, Sheet2 sayfasının A sütununda aramasını ve Sheet 1 sayfasının N sütununa "Var" - "Yok" yazmasını aynı sayfada bulunan Date başlığı altında bulunan tarihlerinde O sütununa aktarmasını istiyorum. Date sütununda bir değer yok ise '-' işareti koymasını gerekiyor. Sheet2 sayfasının A sütununda mükerrer veri var ise Data sütunundaki en küçük tarih yazmalı.

Yaklaşık olarak Sheet1 sayfasında yer alan satır sayısı 30.000 civarıdır.
Sheet2 sayfasındaki satır sayısı 35.000 civarıdır.

Upload sitesine excel dosyamın tamamlanmış halini ekliyorum.

Dosya İndir

Bir çok konuyu inceledim. Kapalı dosyadan veri alma-çekme gibi örnekleri inceledim. Bu tarz daha kolay yapabileceğim farklı yöntemler varsa o şekilde de olabilir.

SÜRÇ-İ LİSAN ETTİKSE AFFOLA!

 

[Ziynettin]

Dosyanız

Option Explicit
Sub veri_Al()
Dim a(), b(), c(), d As Object, krt
Dim s1 As Worksheet, s2 As Worksheet
Dim i As Long, t As Double
    t = TimeValue(Now)
    Set s1 = Sheets("Sheet1")
    Set s2 = Sheets("Sheet2")
    Set d = CreateObject("scripting.dictionary")
    a = s2.Range("A2:B" & s2.Cells(Rows.Count, 1).End(3).Row).Value
    b = s1.Range("C2:C" & s1.Cells(Rows.Count, 3).End(3).Row).Value
        For i = 1 To UBound(a)
            krt = CStr(a(i, 1))
            If Not d.exists(krt) Then
                d(krt) = i
            Else
                If a(i, 2) < a(d(krt), 2) Then
                    d(krt) = i
                End If
            End If
        Next i
    ReDim c(1 To UBound(b), 1 To 2)
        For i = 1 To UBound(b)
            krt = CStr(b(i, 1))
            If d.exists(krt) Then
                c(i, 1) = "Var"
                c(i, 2) = a(d(krt), 2)
            Else
                c(i, 1) = "YOK"
                c(i, 2) = "-"
            End If
        Next i
s1.[O2].Resize(UBound(b)).NumberFormat = "dd.mm.yyyy"
s1.[N2].Resize(UBound(b), 2) = c
MsgBox "İşlem Bitti." & vbLf & CDate(TimeValue(Now) - t), vbInformation
End Sub

 

[MrExcelMr]

@Ziynettin Bey Elinize sağlık beni çok büyük bir dertten kurtardınız.

Ziynettin Bey bir sorum olacak.
Sheet2 sayfasında "C" sütununda veri olsaydı ve Sheet1 "P" sütununa aynı mantıkla değerleri aktarmak istersem yazmış olduğunuz kodların ne gibi ekleme yapılmalıdır.

 

[Utekiner]

@Ziynettin Bey Elinize sağlık beni çok büyük bir dertten kurtardınız.

Ziynettin Bey bir sorum olacak.
Sheet2 sayfasında "C" sütununda veri olsaydı ve Sheet1 "P" sütununa aynı mantıkla değerleri aktarmak istersem yazmış olduğunuz kodların ne gibi ekleme yapılmalıdır.

@Ziynettin Bey,
konu hakkında ufak bir bilgilendirme yaparsa süper olur. On numara yazdığı kodlar tam arşivlik.

 

[Ziynettin]

@Ziynettin Bey Elinize sağlık beni çok büyük bir dertten kurtardınız.

Ziynettin Bey bir sorum olacak.
Sheet2 sayfasında "C" sütununda veri olsaydı ve Sheet1 "P" sütununa aynı mantıkla değerleri aktarmak istersem yazmış olduğunuz kodların ne gibi ekleme yapılmalıdır.

Option Explicit
Sub veri_Al_1()
Dim a(), b(), c(), d As Object, krt
Dim s1 As Worksheet, s2 As Worksheet
Dim i As Long, t As Double
    t = TimeValue(Now)
    Set s1 = Sheets("Sheet1")
    Set s2 = Sheets("Sheet2")
    Set d = CreateObject("scripting.dictionary")
    a = s2.Range("A2:C" & s2.Cells(Rows.Count, 1).End(3).Row).Value
    b = s1.Range("C2:C" & s1.Cells(Rows.Count, 3).End(3).Row).Value
        For i = 1 To UBound(a)
            krt = CStr(a(i, 1))
            If Not d.exists(krt) Then
                d(krt) = i
            Else
                If a(i, 2) < a(d(krt), 2) Then
                    d(krt) = i
                End If
            End If
        Next i
    ReDim c(1 To UBound(b), 1 To 3)
        For i = 1 To UBound(b)
            krt = CStr(b(i, 1))
            If d.exists(krt) Then
                c(i, 1) = "Var"
                c(i, 2) = a(d(krt), 2)
                c(i, 3) = a(d(krt), 3)
            Else
                c(i, 1) = "YOK"
                c(i, 2) = "-"
                c(i, 3) = "Bulunamdı"
            End If
        Next i
s1.[O2].Resize(UBound(b)).NumberFormat = "dd.mm.yyyy"
s1.[N2].Resize(UBound(b), 3) = c
MsgBox "İşlem Bitti." & vbLf & CDate(TimeValue(Now) - t), vbInformation
End Sub

 

[MrExcelMr]

@Ziynettin Bey yardımlarınız için çok ama çok teşekkür ederim. Selamlar.

 

[gicimi]

@Ziynettin Abi, Eline sağlık döktürmüşsün.

 

[Ziynettin]

@MrExcelMr bu kadar fazla veride denemedim. İşlem süresini bildiri

 

[MrExcelMr]

@Ziynettin Bey tabi
yaklaşık olarak 15 ile 22 sn. arası değişiyor. Benim Computer.

 

[Ziynettin]

@Ziynettin Abi, Eline sağlık döktürmüşsün.

Teşekkür edirim.