Soru Liste Kıyaslama,

[MrExcelMr]

Merhaba;
Resimdeki örnekte belirtildiği gibi Barkod1 ve Barkod2 listelerinde aynı olan değerleri renklendirmek ve İki liste arasındaki benzersiz değerleri ayırmak istiyorum.
Bu işlemi formüllerden faydalanarak yapıyorum. Makro konusunda destek olabilir misiniz.

İki liste ortalama 1.000 ve 2.500 satırdan oluşmaktadır.

 

[YUSUF44]

Dosyayı resim olarak değil de excel dosyası olarak paylaşır mısınız?

 

[MrExcelMr]

@YUSUF44 Bey dosya,
Download

 

[Ziynettin]

Sub kod()
a = Range("A2:A" & Cells(Rows.Count, 1).End(3).Row).Value
Set dc1 = CreateObject("scripting.dictionary")
    For i = 1 To UBound(a)
        krt = CStr(a(i, 1))
        dc1(krt) = krt
    Next i
b = Range("B2:B" & Cells(Rows.Count, 2).End(3).Row).Value
ReDim c(1 To UBound(b), 1 To 1)
    For i = 1 To UBound(b)
        krt = CStr(b(i, 1))
        If Not dc1.exists(krt) Then
            s = s + 1
            c(s, 1) = krt
        Else
            dc1.Remove krt
        End If
    Next i
ReDim c2(1 To UBound(a), 1 To 1)
    For i = 1 To UBound(a)
        krt = CStr(a(i, 1))
        If dc1.exists(krt) Or dc1.Count = 0 Then
            n = n + 1
            c2(n, 1) = krt
        End If
    Next i
Range("E2:F" & Rows.Count) = ""
If s > 0 Then [E2].Resize(s) = c
If n > 0 Then [F2].Resize(n) = c2
MsgBox "İşlem tamam.", vbInformation
End Sub

 

[MrExcelMr]

@Ziynettin Bey A ve B sütunundaki aynı verileri renklendirmiyor. E ve F sütunlarına benzersiz değerleri getiriyor. Renklendirme konusunda destek olabilir misiniz.

 

[YUSUF44]

Renklendirmeyi koşullu biçimlendirme ile yapabilirsiniz. Bunun için :

A2'den itibaren aşağı doğru seçin (örneğin A2:A30)
Koşullu biçimlendirme menüsünden yeni kural ekleyin
Kural olarak formül kullanmayı seçin
Formül kısmına aşağıdaki formülü yazın:

=EĞERSAY($B$2:$B$30;$A2)>0
Biçim ayarını yapıp işlemi tamamlayın.

B2'den itibaren aşağı doğru seçin (Örneğin B2:B30)
Koşullu biçimlendirme menüsünden yeni kural ekleyin
Kural olarak formül kullanmayı seçin
Formül kısmına aşağıdaki formülü yazın:

=EĞERSAY($A$2:$A$30;$B2)>0
Biçim ayarını yapıp işlemi tamamlayın.

 

[gicimi]

Sub kod()
a = Range("A2:A" & Cells(Rows.Count, 1).End(3).Row).Value
Set dc1 = CreateObject("scripting.dictionary")
    For i = 1 To UBound(a)
        krt = CStr(a(i, 1))
        dc1(krt) = krt
    Next i
b = Range("B2:B" & Cells(Rows.Count, 2).End(3).Row).Value
ReDim c(1 To UBound(b), 1 To 1)
    For i = 1 To UBound(b)
        krt = CStr(b(i, 1))
        If Not dc1.exists(krt) Then
            s = s + 1
            c(s, 1) = krt
        Else
            dc1.Remove krt
        End If
    Next i
ReDim c2(1 To UBound(a), 1 To 1)
    For i = 1 To UBound(a)
        krt = CStr(a(i, 1))
        If dc1.exists(krt) Or dc1.Count = 0 Then
            n = n + 1
            c2(n, 1) = krt
        End If
    Next i
Range("E2:F" & Rows.Count) = ""
If s > 0 Then [E2].Resize(s) = c
If n > 0 Then [F2].Resize(n) = c2
MsgBox "İşlem tamam.", vbInformation
End Sub

Ziynettin Bey kod gayet güzel çalışıyor. Sadece E sütununa aktarılan değerler alt alta gelmiyor.
Bir değer E2 ise diğer değer E20 yazıyor.

 

[YUSUF44]

Ziynettin Bey kod gayet güzel çalışıyor. Sadece E sütununa aktarılan değerler alt alta gelmiyor.
Bir değer E2 ise diğer değer E20 yazıyor.

Ziynettin Bey'in kodlarını çalıştırdığımda aynen örnek dosyanızdaki sonucu aldım. Sizde farklı sonuç veriyorsa dosyanızda farklılık vardır. Dosyayı o haliyle paylaşırsanız iyi olur.

 

[gicimi]

@YUSUF44 bey şirket pc malesef paylaşım yapamıyorum. B sütununa aralık bırakarak bir kaç rakam yazıyorum. Kodu çalıştırdığımda E sütununa gelen değerler alt alta gelmedi. İş yerindeki farklı bir pc denedim aynı hatayı verdi.

 

[YUSUF44]

Sayın ziynettin'in kodları kadar hızlı olmasa da aşağıdaki kodları deneyin:

Sub kontrol()
sonA = Cells(Rows.Count, "A").End(3).Row
sonB = Cells(Rows.Count, "B").End(3).Row
sonE = WorksheetFunction.Max(2, Cells(Rows.Count, "E").End(3).Row)
sonF = WorksheetFunction.Max(2, Cells(Rows.Count, "F").End(3).Row)
Range("E2:E" & sonE).ClearContents
Range("F2:F" & sonF).ClearContents

For a = 2 To sonA
    If Cells(a, "A") <> "" And WorksheetFunction.CountIf(Range("B2:B" & sonB), Cells(a, "A")) = 0 Then
        yeniF = Cells(Rows.Count, "F").End(3).Row + 1
        Cells(yeniF, "F") = Cells(a, "A")
    End If
Next
For b = 2 To sonB
    If Cells(b, "B") <> "" And WorksheetFunction.CountIf(Range("A2:A" & sonA), Cells(b, "B")) = 0 Then
        yeniE = Cells(Rows.Count, "E").End(3).Row + 1
        Cells(yeniE, "E") = Cells(b, "B")
    End If
Next
End Sub

 

[Ziynettin]

A ve B sütunundaki aynı verileri renklendirmiyor. E ve F sütunlarına benzersiz değerleri getiriyor. Renklendirme konusunda destek olabilir misiniz

B sütununa aralık bırakarak bir kaç rakam yazıyorum. Kodu çalıştırdığımda E sütununa gelen değerler alt alta gelmedi. İş yerindeki farklı bir pc denedim aynı hatayı verdi.

Sub test()
Set a1 = Range("A2:A" & Cells(Rows.Count, 1).End(3).Row)
a = a1.Value
Set dc1 = CreateObject("scripting.dictionary")
    For i = 1 To UBound(a)
        krt = CStr(a(i, 1))
        If krt <> "" Then dc1(krt) = krt
    Next i
    
Set b1 = Range("B2:B" & Cells(Rows.Count, 2).End(3).Row)
b = b1.Value
Union(a1, b1).Interior.ColorIndex = xlNone
ReDim c(1 To UBound(b), 1 To 1)
    For i = 1 To UBound(b)
        krt = CStr(b(i, 1))
        If krt <> "" Then
            If Not dc1.exists(krt) Then
                s = s + 1
                c(s, 1) = krt
                b1.Cells(i, 1).Interior.ColorIndex = 6
            Else
                dc1.Remove krt
            End If
        End If
    Next i
ReDim c2(1 To UBound(a), 1 To 1)
    For i = 1 To UBound(a)
        krt = CStr(a(i, 1))
        If krt <> "" Then
            If dc1.exists(krt) Or dc1.Count = 0 Then
                a1.Cells(i, 1).Interior.ColorIndex = 6
                n = n + 1
                c2(n, 1) = krt
            End If
        End If
    Next i
Range("E2:F" & Rows.Count) = ""
If s > 0 Then [E2].Resize(s) = c
If n > 0 Then [F2].Resize(n) = c2
MsgBox "İşlem tamam.", vbInformation
End Sub