2 liste karşılaştırma

[modoste]

merhaba sayın hocalarım
ekli dosyamda yanyana 2 liste yapacağım ve liste 1 de olup liste 2 de olmayan vede
liste 2 de olup liste 1 de olmayanların hem koşullu biçimlendirme ile hemde başka biryerde listelenmesi ile ilgili çözüm gerekmektedir.

 

[YUSUF44]

Benzersiz olan sütun D ve I!daki fiş sütünu mudur?

 

[modoste]

benzersizlik kriteri yalnızca bir satır değil 4 satırı içerecek (tarih-fiş no-açıklama-plaka no)

 

[YUSUF44]

Eğer öyleyse makro ile farklı olanları aktarmak için aşağıdaki kodları bir modüle kopyalayıp deneyiniz:

Sub farklar()
Set s1 = Sheets("Liste")
son1 = s1.Cells(Rows.Count, "D").End(3).Row
son2 = s1.Cells(Rows.Count, "I").End(3).Row
For i = 13 To son1
    If WorksheetFunction.CountIf(s1.Range("I12:I" & son2), s1.Cells(i, "D")) = 0 Then
        yeni = s1.Cells(Rows.Count, "S").End(3).Row + 1
        s1.Range("C" & i & ":F" & i).Copy: s1.Cells(yeni, "R").PasteSpecial Paste:=xlValues
    End If
Next
yeni = Empty
For j = 13 To son2
    If WorksheetFunction.CountIf(s1.Range("D12:D" & son1), s1.Cells(j, "I")) = 0 Then
        yeni = s1.Cells(Rows.Count, "X").End(3).Row + 1
        s1.Range("H" & j & ":K" & j).Copy: s1.Cells(yeni, "W").PasteSpecial Paste:=xlValues
    End If
Next
yeni = Empty
i = Empty
j = Empty
End Sub

Koşullu biçimlendirme için Liste1'de C13:F33 seçin. Koşullu biçimlendirme menüsünden yeni kural ekleyip formülü seçin. Formül alanına aşağıdaki formülü yazın ve biçim ayarını yapıp işlemi tamamlayın:

=VE($D13<>"";EĞERSAY($I$13:$I$33;$D13)=0)

Aynı şekilde Liste2'de R13:U33 seçin ve formül olarak aşağıdaki formülü kullanın:

=VE($I13<>"";EĞERSAY($D$13:$D$33;$I13)=0)

 

[modoste]

yardımcı sütun kullanarak 4 sütunu birleştir formülü ile bir sütunmuş gibi yaparak 2 tabloyuda tek sütuna indirip sonuca gitmek çözüm ama daha başka kolay yolu varmıdır hocam

 

[YUSUF44]

Yukarda verdiğim cevap benzersiz tek sütuna göredir.

 

[modoste]

çözümü formülleri yada makroyu soruma göre değiştirebilir miyiz

 

[çıtır]

1.Çizelge için C13:F33 seçiniz.Koşullu biçimlendirme formülü

=VE($C13<>"";$D13<>"";$E13<>"";$F13<>"";ÇOKEĞERSAY($H$13:$H$34;$C13;$I$13:$I$34;$D13;$J$13:$J$34;$E13;$K$13:$K$34;$F13)=0)

2.Çizelge için H13:K33 seçiniz.Koşullu biçimlendirme formülü

=VE($H13<>"";$I13<>"";$J13<>"";$K13<>"";ÇOKEĞERSAY($C$13:$C$34;$H13;$D$13:$D$34;$I13;$E$13:$E$34;$J13;$F$13:$F$34;$K13)=0)

1.Formülle çözüm.R13 kopyalayınız yeterinçe sağa ve aşağı çekerek çoğaltınız.

=EĞERHATA(İNDİS($C$1:$F$34;(TOPLAMA(15;6;(SATIR($A$13:$A$34)/(($C$13:$C$34<>"")*(ÇOKEĞERSAY($H$13:$H$34;$C$13:$C$34;$I$13:$I$34;$D$13:$D$34;$J$13:$J$34;$E$13:$E$34;$K$13:$K$34;$F$13:$F$34)=0)));SATIR(A1)));SÜTUN(A$1));"")

2.Formülle çözüm.W13 kopyalayınız yeterinçe sağa ve aşağı çekerek çoğaltınız.

=EĞERHATA(İNDİS($H$1:$K$34;TOPLAMA(15;6;(SATIR($A$13:$A$34)/(($H$13:$H$34<>"")*(ÇOKEĞERSAY($C$13:$C$34;$H$13:$H$34;$D$13:$D$34;$I$13:$I$34;$E$13:$E$34;$J$13:$J$34;$F$13:$F$34;$K$13:$K$34)=0)));SATIR($A1));SÜTUN(A$1));"")

 

[modoste]

tüm formülleri uyguladım sonuçlar doğru Sayın Çıtır
emeğinize sağlık

 

[YUSUF44]

Makroyu çok sütuna göre güncelledim:

Sub farklar()
Set s1 = Sheets("Liste")
son1 = s1.Cells(Rows.Count, "D").End(3).Row
son2 = s1.Cells(Rows.Count, "I").End(3).Row
For i = 13 To son1
    If WorksheetFunction.CountIfs(s1.Range("H12:H" & son2), s1.Cells(i, "C"), s1.Range("I12:I" & son2), s1.Cells(i, "D"), _
                                s1.Range("J12:J" & son2), s1.Cells(i, "E"), s1.Range("K12:K" & son2), s1.Cells(i, "F")) = 0 Then
        yeni = s1.Cells(Rows.Count, "S").End(3).Row + 1
        s1.Range("C" & i & ":F" & i).Copy: s1.Cells(yeni, "R").PasteSpecial Paste:=xlValues
    End If
Next
yeni = Empty
For j = 13 To son2
    If WorksheetFunction.CountIfs(s1.Range("C12:C" & son1), s1.Cells(j, "H"), s1.Range("D12:D" & son1), s1.Cells(j, "I"), _
                                s1.Range("E12:E" & son1), s1.Cells(j, "J"), s1.Range("F12:F" & son1), s1.Cells(j, "K")) = 0 Then
        yeni = s1.Cells(Rows.Count, "X").End(3).Row + 1
        s1.Range("H" & j & ":K" & j).Copy: s1.Cells(yeni, "W").PasteSpecial Paste:=xlValues
    End If
Next
yeni = Empty
i = Empty
j = Empty
End Sub

 

[modoste]

teşekkür ederim sayın yusuf 44 sizden gelen makroyuda kullanacağım
sayın hocam makro ile çözüm doğrudur. koşullu biçimlendirme ile olan kısım için makro yapabilir miyiz. dolguların rengi sarı olsun

 

[YUSUF44]

Aşağıdaki gibi kullanabilirsiniz:

Sub farklar()
Set s1 = Sheets("Liste")
son1 = s1.Cells(Rows.Count, "D").End(3).Row
son2 = s1.Cells(Rows.Count, "I").End(3).Row
For i = 13 To son1
    If WorksheetFunction.CountIfs(s1.Range("H12:H" & son2), s1.Cells(i, "C"), s1.Range("I12:I" & son2), s1.Cells(i, "D"), _
                                s1.Range("J12:J" & son2), s1.Cells(i, "E"), s1.Range("K12:K" & son2), s1.Cells(i, "F")) = 0 Then
        yeni = s1.Cells(Rows.Count, "S").End(3).Row + 1
        s1.Range("C" & i & ":F" & i).Copy: s1.Cells(yeni, "R").PasteSpecial Paste:=xlValues
        s1.Range("C" & i & ":F" & i).Interior.Color = vbYellow
    End If
Next
yeni = Empty
For j = 13 To son2
    If WorksheetFunction.CountIfs(s1.Range("C12:C" & son1), s1.Cells(j, "H"), s1.Range("D12:D" & son1), s1.Cells(j, "I"), _
                                s1.Range("E12:E" & son1), s1.Cells(j, "J"), s1.Range("F12:F" & son1), s1.Cells(j, "K")) = 0 Then
        yeni = s1.Cells(Rows.Count, "X").End(3).Row + 1
        s1.Range("H" & j & ":K" & j).Copy: s1.Cells(yeni, "W").PasteSpecial Paste:=xlValues
        s1.Range("H" & j & ":K" & j).Interior.Color = vbYellow
    End If
Next
yeni = Empty
i = Empty
j = Empty
Application.CutCopyMode = False
End Sub

 

[çıtır]

tüm formülleri uyguladım sonuçlar doğru Sayın Çıtır
emeğinize sağlık

Sayın modoste;
Dönüş yaptığınız için teşekkür ederim.Kolay gelsin.