VBA ile Çaprazara Benzeri Arama ile Veri Çekme

[teknoman]

Merhaba ekte yer alan sayfa1 deki yeşil ve mavi alandaki verileri sayfa2 de aynı renkteki alandaki verileri arayıp denk gelen sayfa2 deki sarı renkteki hücre değerlerini sayfa1 deki sarı renkli alanlara yazdırmak istiyorum. Bunu ekteki dosyada da görüneceği üzerine formülüze ettim ama çok fazla veri olduğu için bu yöntem dosyanın kasmasına sebep oluyor. Dosyanın daha stabil ve hızlı çalışması için ve verilerinde sürekli güncellendiğinden VBA kod ile bu sorunu aşabileceğimizi umuyorum.

Yardımlarınız için şimdiden teşekkürler.

 

[muygun]

Merhaba;
Eki deneyin.
İyi çalışmalar.

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Fast_XLookup()
    Dim S1 As Worksheet, S2 As Worksheet, My_Array As Object
    Dim X As Long, Y As Integer, My_Data_X As Variant
    Dim My_Data_Y As Variant, Process_Time As Double
    
    Process_Time = Timer
    
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    Set My_Array = VBA.CreateObject("Scripting.Dictionary")
    
    My_Data_X = S2.Range("A2:H" & S2.Cells(S2.Rows.Count, 1).End(3).Row).Value
    
    For X = LBound(My_Data_X, 1) To UBound(My_Data_X, 1)
        My_Array.Item(My_Data_X(X, 1) & My_Data_X(X, 8)) = My_Data_X(X, 7)
    Next
    
    My_Data_X = S1.Range("B2:B" & S1.Cells(S1.Rows.Count, 2).End(3).Row).Value
    My_Data_Y = S1.Range("E1").Resize(, S1.Cells(1, S1.Columns.Count).End(1).Column - 4).Value
    
    ReDim My_Result_List(1 To UBound(My_Data_X, 1), 1 To UBound(My_Data_Y, 2))
    
    For X = LBound(My_Data_X, 1) To UBound(My_Data_X, 1)
        For Y = LBound(My_Data_Y, 1) To UBound(My_Data_Y, 2)
            If My_Array.Exists(My_Data_X(X, 1) & My_Data_Y(1, Y)) Then
                My_Result_List(X, Y) = My_Array.Item(My_Data_X(X, 1) & My_Data_Y(1, Y))
            End If
        Next
    Next
    
    S1.Range("E2").Resize(S1.Rows.Count - 1, S1.Columns.Count - 4).ClearContents
    S1.Range("E2").Resize(UBound(My_Result_List, 1), UBound(My_Result_List, 2)) = My_Result_List
    
    Set S1 = Nothing
    Set S2 = Nothing
    Set My_Array = Nothing
    
    MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & vbCrLf & _
           "İşlem süresi ; " & Format(Timer - Process_Time, "0.00") & " Saniye"
End Sub

 

[teknoman]

Hocalarım
@muygun ve
@Korhan Ayhan ellerinize sağlık.
iyi çalışmalar dilerim