Hücredeki benzer verileri yan hücreye alma hk.

[Muratizmir]

Merhaba.
Elimde yaklaşık 200 bin satırlık bir tablo var 2 sütundan oluşuyor.
Her hücrenin hemen yanındaki hücrede veriler bulunuyor.
Örnek A 1 hücresindeki verinin değeri yanındaki B1 hücresinde yazıyor.
Ancak A sütununda benzer birçok verim olmasına rağmen B sütunumda bazı hücrelerimde bu değerler yazmıyor.
Benim yapmak istediğim A1-A2-A3 dolu ve aynı veri olduğunu varsayalım bunlara karşılık gelen B1-B2 ve B3 den sadece B1 de veri var B2 ve B3 boş.
Belliki bunlarda B1 deki verinin aynısı olacak.
Resimdeki sarı olan kısımlara bir üsteki değer gelmeli. Yani B3=A2363
B6=B5636 olmalıdır.
Bunu yapabileceğim bir formül yada makro varmıdır?
Resim koydum örnek olsun diye ancak başka bir şey daha gerekirse yükleyebilirim.
Şimdiden çok teşekkür ederim.

 

[Korhan Ayhan]

Verilerinizi YEDEKLEYEREK kodu deneyiniz.

Kod çalıştığında D-E hücrelerinde yeni listeniz oluşur.

Option Explicit

Sub Fast_Vlookup()
    Dim Liste As Variant, Son As Long, X As Long
    Dim Dizi As Object, Say As Long, Zaman As Double
    
    Zaman = Timer
    
    Application.ScreenUpdating = False
    
    Son = Cells(Rows.Count, 1).End(3).Row
    Liste = Range("A1:B" & Son).Value
    
    Set Dizi = CreateObject("Scripting.Dictionary")
    
    For X = 1 To UBound(Liste)
        If Liste(X, 2) <> "" Then
            Dizi(Liste(X, 1)) = Liste(X, 2)
        End If
    Next
    
    For X = 1 To UBound(Liste)
        If Dizi.Exists(Liste(X, 1)) Then
            Say = Say + 1
            ReDim Preserve Liste(1 To UBound(Liste), 1 To 2)
            Liste(Say, 2) = Dizi.Item(Liste(X, 1))
        End If
    Next
    
    Range("D1:E" & Say) = Liste
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

 

[Korhan Ayhan]

Aşağıdaki yapı biraz daha hızlı sonuç veriyor.

Sub Fast_Vlookup()
    Dim Liste As Variant, X As Long
    Dim Dizi As Object, Zaman As Double
 
    Set Dizi = CreateObject("Scripting.Dictionary")
 
    Zaman = Timer
 
    Application.ScreenUpdating = False
 
    With Worksheets("Sayfa1")
        Liste = .Range("A1:B" & .Cells(.Rows.Count, 1).End(3).Row).Value
    End With
 
    With Dizi
        For X = 1 To UBound(Liste)
            If Liste(X, 2) <> "" Then
                If Not .Exists(Liste(X, 1)) Then
                    .Add Liste(X, 1), Liste(X, 2)
                End If
            End If
        Next
 
        For X = 1 To UBound(Liste)
            Liste(X, 2) = .Item(Liste(X, 1))
        Next
    End With
 
    With Worksheets("Sayfa1")
        .Range("D1:E1").Resize(UBound(Liste)).Value = Liste
    End With
 
    Application.ScreenUpdating = True
 
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

 

[Muratizmir]

Çok teşekkür ederim çalıştı. Aslında birincisi de çalışmıştı ancak sanırım sizde fakettiniz bazı hücrelerde yazmıyordu. B hücresinde alttaki veriyi arıyordu muhtemelen. Ama ikincisi kusursuz.
Nasıl teşekkür ederim bilemiyorum.
İyiki bu siteyi yıllar evvel keşfetmişim. Bir ara Altın üye idim. Tekrar almak farz oldu