Çözüldü İki Sütunu Karşılaştırma

[gicimi]

Merhaba;
Ekteki örnekte A ve B sütununda yer alan isimleri Kırmızı renge boyamasını ve C sütununa aktarmasını istiyorum. A-B sütunundaki veri sayısı 5.000 adettir. Yardımcı olabilir misiniz. Teşekkürler.

 

[cems]

https://www.excel.web.tr/threads/iki-liste-karsilastirma-6-farkli-muekerrer-bulma.179239/

Burada en alttaki kod ve örneği inceleyiniz .

 

[gicimi]

@cems Hocam C Sütununa aynı olanları nasıl yazdırabilirim.

 

[cems]

Sayın Evren Gizlen 'in kodları ile

Private Sub CommandButton1_Click()
Dim sat1 As Long, sat2 As Long, i As Long, sat3 As Long
Range("C:C").ClearContents
Application.ScreenUpdating = False
sat1 = Cells(Rows.Count, "A").End(xlUp).Row
sat2 = Cells(Rows.Count, "B").End(xlUp).Row
For i = 1 To sat2
    If WorksheetFunction.CountIf(Range("A1:A" & sat1), Cells(i, "B").Value) > 0 Then
        sat = sat + 1
        Cells(sat, "C").Value = Cells(i, "B").Value
    End If
Next i
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlanmıştır." & vbLf & "evrengizlen@hotmail.com", _
    vbOKOnly + vbInformation, Application.UserName
End Sub

Dosyanız da ektedir .
Dosya vba nın çalışabilmesi için xlsm olarak farklı kaydedilmiştir

 

[gicimi]

@cems Teşekkür ederim. @Orion1 hocama ve size ilginiz için.

 

[cems]

Bir ufak hata buldum, kodları ve dosyayı düzeltiyorum sayfayı yenileyin

 

[Korhan Ayhan]

Alternatif;

Option Explicit

Private Sub CommandButton1_Click()
    Dim Dizi As Object, Benzerler As Object
    Dim SonA As Long, SonB As Long, Veri As Range
    Dim Liste As Variant, X As Long, Zaman As Double
    
    Zaman = Timer
    
    Application.ScreenUpdating = False
    
    Set Dizi = CreateObject("Scripting.Dictionary")
    Set Benzerler = CreateObject("Scripting.Dictionary")
    
    Range("A2:B" & Rows.Count).Interior.ColorIndex = xlNone
    Range("C2:C" & Rows.Count).ClearContents
    
    SonA = Cells(Rows.Count, 1).End(3).Row
    SonB = Cells(Rows.Count, 2).End(3).Row
    
    If SonA >= SonB Then
        Liste = Range("A2:A" & SonA).Value
        For X = 1 To UBound(Liste)
            If Liste(X, 1) <> "" Then Dizi.Item(Liste(X, 1)) = Liste(X, 1)
        Next
        Liste = Range("B2:B" & SonB).Value
        For X = 1 To UBound(Liste)
            If Liste(X, 1) <> "" Then
                If Dizi.Exists(Liste(X, 1)) Then
                    If Not Benzerler.Exists(Liste(X, 1)) Then Benzerler.Add Dizi.Item(Liste(X, 1)), Nothing
                End If
            End If
        Next
    Else
        Liste = Range("B2:B" & SonA).Value
        For X = 1 To UBound(Liste)
            If Liste(X, 1) <> "" Then Dizi.Item(Liste(X, 1)) = Liste(X, 1)
        Next
        Liste = Range("A2:A" & SonA).Value
        For X = 1 To UBound(Liste)
            If Liste(X, 1) <> "" Then
                If Dizi.Exists(Liste(X, 1)) Then
                    If Not Benzerler.Exists(Liste(X, 1)) Then Benzerler.Add Dizi.Item(Liste(X, 1)), Nothing
                End If
            End If
        Next
    End If
    
    Range("C2").Resize(Benzerler.Count) = Application.Transpose(Benzerler.Keys)
    
    With Range("A2:B" & WorksheetFunction.Max(SonA, SonB))
        .FormatConditions.Add Type:=xlExpression, Formula1:="=COUNTIF($C:$C;A2)"
        .FormatConditions(.FormatConditions.Count).Interior.ColorIndex = 3
    End With

    Application.ScreenUpdating = True

    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00000") & " Saniye"
End Sub

 

[gicimi]

@Korhan Ayhan Teşekkür ederim hocam. İyi Çalışmalar.