• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

2 liste karşılaştırma

M

modoste

Altın Üye
Katılım
31 Mayıs 2008
Mesajlar
3,714
Excel Vers. ve Dili
Microsoft OFFİCE Ev ve İş 2019 TR
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.
 

Ekli dosyalar

Benzersiz olan sütun D ve I!daki fiş sütünu mudur?
 
benzersizlik kriteri yalnızca bir satır değil 4 satırı içerecek (tarih-fiş no-açıklama-plaka no)
 
Eğer öyleyse makro ile farklı olanları aktarmak için aşağıdaki kodları bir modüle kopyalayıp deneyiniz:

Kod: 
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:

Kod: 
=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:

Kod: 
=VE($I13<>"";EĞERSAY($D$13:$D$33;$I13)=0)
 
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
 
Yukarda verdiğim cevap benzersiz tek sütuna göredir.
 
çözümü formülleri yada makroyu soruma göre değiştirebilir miyiz
 
1.Çizelge için C13:F33 seçiniz.Koşullu biçimlendirme formülü
Kod: 
=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ü
Kod: 
=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.
Kod: 
=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.
Kod: 
=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));"")
 
Son düzenleme:
tüm formülleri uyguladım sonuçlar doğru Sayın Çıtır
emeğinize sağlık
 
Son düzenleme:
Makroyu çok sütuna göre güncelledim:

Kod: 
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
 
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
 
Aşağıdaki gibi kullanabilirsiniz:

Kod: 
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
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst