İki Liste Karşılaştırma {6 Farklı Mükerrer Bulma}

gicimi · 30 Mart 2019

Merhaba;

Ekteki çalışmada birden fazla mükerrer karşılaştırma yapmak istiyorum. Makro ile yapmak için yardımcı olabilir misiniz. Ortalama satır sayısı 5.000 adettir.

A Sütununda olup B sütununda Olmayanlar
B Sütununda Olup A Sütununda Olmayanlar
A ve B Sütununda Olanlar
A Sütunundaki Mükerrer Bul
B Sütunundaki Mükerrer Bul
A ve B sütunlarındaki Mükerrer olanları renklendir.

cems · 30 Mart 2019

Makro ile bir çözüm alternatifi .. Tek tek tuşlara değil tek bir tuşa bağlı olarak :

Kod:

Sub Düğme7_Tıklat()

Range("d2:h49") = ""

    Dim rngCell As Range
    For Each rngCell In Range("A2:A40")
        If WorksheetFunction.CountIf(Range("B2:B40"), rngCell) = 0 Then
            Range("D" & Rows.Count).End(xlUp).Offset(1) = rngCell
        End If
    Next
    For Each rngCell In Range("B2:B40")
        If WorksheetFunction.CountIf(Range("A2:A40"), rngCell) = 0 Then
            Range("E" & Rows.Count).End(xlUp).Offset(1) = rngCell
        End If
    Next
   
     For Each rngCell In Range("B2:B40")
        If WorksheetFunction.CountIf(Range("A2:A40"), rngCell) = 1 Then
            Range("F" & Rows.Count).End(xlUp).Offset(1) = rngCell
        End If
    Next
   
    For Each rngCell In Range("A2:A40")
        If WorksheetFunction.CountIf(Range("A2:A40"), rngCell) > 1 Then
            Range("G" & Rows.Count).End(xlUp).Offset(1) = rngCell
        End If
    Next
   
     For Each rngCell In Range("B2:B40")
        If WorksheetFunction.CountIf(Range("B2:B40"), rngCell) > 1 Then
            Range("H" & Rows.Count).End(xlUp).Offset(1) = rngCell
        End If
    Next
   
   
MsgBox " Mükerrerler listelendi "
   
ThisWorkbook.Save

Dener misiniz ?

gicimi · 30 Mart 2019

@cems Teşekkür ederim. Hocam elinize sağlık

gicimi · 30 Mart 2019

@cems A ve B sütunlarındaki Mükerrer olanları renklendirebilir miyiz. Ayrı Butonla yapabilir miyiz.

cems · 30 Mart 2019

Onu unuttum , deniyorum ...

cems · 30 Mart 2019

Sayfayı yenileyerek eklenen yeni dosyayı indirip deneyiniz.

Renklendirme kısmını save etmeden ... ( eğer save etsin isterseniz End sub dan bir önceki satıra "Thisworkbook.save" yazın. Bu şekilde dosyayı kapatırsanız renklendirmelerin silinmesi gerekir .

Kod:

Sub avebkolonmukrenk()

    Dim myRng As Range
    Dim lastCell As Long

    'Get the last row
    Dim lastRow As Integer
    lastRow = ActiveSheet.UsedRange.Rows.Count

    'Debug.Print "Last Row is " & lastRow

    Dim a As Range
    Dim b As Range

    Application.ScreenUpdating = False

    For Each a In Worksheets("Sayfa1").Range("A2:A" & lastRow).Cells
        For Each b In Worksheets("Sayfa1").Range("B2:B" & lastRow).Cells
            a.Interior.Color = vbRed
            If (InStr(1, b, a, 1) > 0) Then
                a.Interior.Color = vbWhite
                Exit For
            End If
        Next
    Next

    For Each a In Worksheets("Sayfa1").Range("B2:B" & lastRow).Cells
        For Each b In Worksheets("Sayfa1").Range("A2:A" & lastRow).Cells
            a.Interior.Color = vbRed
            If (InStr(1, b, a, 1) > 0) Then
                a.Interior.Color = vbWhite
                Exit For
            End If
        Next
    Next

Application.ScreenUpdating = True

End Sub

gicimi · 30 Mart 2019

@cems ilginiz için teşekkür ederim. İyi geceler.

cems · 30 Mart 2019

Ayrı buton yazmışsınız , yorgun gözler aynı okudu ..

Ayırmak isterseniz :
1* sayfaya yeni bir tuş ekleyin
2* Tuşun altına ikinci yazılan kodları kopyalamayın , taşıyın ...
3* call ile başlayan satırı silin

İyi geceler

unilll · 24 Nisan 2019

Merhabalar,

Bunu A B C D sütunları kontrol ederek yani aynı sütunda 4 sütunda yapmak mümkün mü?

cems · 24 Nisan 2019

Sanırım örnek dosyayı incelediniz ve daha farklı bir şey istiyorsunuz. Ancak ne istediğinizi anlayamadım.
Çalışmayan ama istediğiniz şekli içeren bir dosya gönderebilir misiniz ? Dosyayı www.filebig.net e yükleyip linki
burada verebilir misiniz ?

unilll · 24 Nisan 2019

Dosyayı inceleyemedim çünkü statüm yetersiz kalıyor.

Aşağıdaki linke gönderdim.

Tablodaki A, B, C, D sütunlarını kontrol ederek (bu sütunlar tek bir satırda olmalı) satırın mükerrer olup olmadığını tespit etmesini (renklendirme, yan sütuna belli bir tanım yazma vb.) istiyorum.

Link: http://www.filebig.net/files/dWjAgnnKXx

cems · 24 Nisan 2019

http://www.filebig.net/files/cdXwHQGMji

unilll · 25 Nisan 2019

cems' Alıntı:
http://www.filebig.net/files/cdXwHQGMji

Bu dosya herhalde sayfanın başındaki paylaştığınız dosya değil mi? Benim yüklediğime de bakabildiniz mi acaba?

halit3 · 25 Nisan 2019

unilll' Alıntı:
Bu dosya herhalde sayfanın başındaki paylaştığınız dosya değil mi? Benim yüklediğime de bakabildiniz mi acaba?

KOD:

Kod:

Sub Sil()
Application.ScreenUpdating = False

son = Cells(Rows.Count, "b").End(3).Row

Range("A2:E" & son).Interior.ColorIndex = xlNone

ReDim ara1(son): ReDim ara2(son)

For t = 2 To son
ara1(t) = Cells(t, "A") & Cells(t, "B") & Cells(t, "C") & Cells(t, "D")
ara2(t) = 1
Next


For i = 2 To son

For j = 2 To son
bulunan = Cells(j, "A") & Cells(j, "B") & Cells(j, "C") & Cells(j, "D")

If ara2(j) = 1 Then
If ara1(i) = bulunan Then
say = say + 1
If say > 1 Then
ara2(j) = 0

Range(Cells(j, "A"), Cells(j, "e")).Interior.ColorIndex = 40
Range(Cells(i, "A"), Cells(i, "e")).Interior.ColorIndex = 40


End If
End If
End If

Next j
say = 0
Next i


Application.ScreenUpdating = True
MsgBox "işlem tamam"
End Sub

halit3 · 25 Nisan 2019

bu kod da farklı birazcık

Kod:

Sub mükerrer()
Application.ScreenUpdating = False

son = Cells(Rows.Count, "b").End(3).Row

Range("A2:E" & son).Interior.ColorIndex = xlNone

ReDim ara1(son): ReDim ara2(son)

For t = 2 To son
ara1(t) = Cells(t, "A") & Cells(t, "B") & Cells(t, "C") & Cells(t, "D")
ara2(t) = 1
Next

say = 3
For i = 2 To son
say2 = 0
For j = 2 To son
bulunan = Cells(j, "A") & Cells(j, "B") & Cells(j, "C") & Cells(j, "D")

If ara2(j) = 1 Then
If ara1(i) = bulunan Then
sat = sat + 1
If sat > 1 Then
ara2(j) = 0

Range(Cells(j, "A"), Cells(j, "e")).Interior.ColorIndex = say
Range(Cells(i, "A"), Cells(i, "e")).Interior.ColorIndex = say

Cells(j, "m") = say
Cells(i, "m") = say
Cells(j, "n") = j & "_" & i

say2 = 1

End If
End If
End If

Next j
sat = 0
If say2 = 1 Then
say = say + 1
If say = 56 Then say = 3
End If
Next i


Application.ScreenUpdating = True
MsgBox "işlem tamam"
End Sub

cems · 25 Nisan 2019

Sayın Halit3 ün kodları ile

http://www.filebig.net/files/rTztJXB3Xu

halit3 · 25 Nisan 2019

bu kad birazcık daha farklı

Kod:

Sub mukerrer()
Application.ScreenUpdating = False

Range("A2:E" & Rows.Count).Interior.ColorIndex = xlNone
Range("J2:M" & Rows.Count).ClearContents
son = Cells(Rows.Count, "b").End(3).Row
ReDim ara1(son): ReDim ara2(son)

For t = 2 To son
ara1(t) = Cells(t, "A") & Cells(t, "B") & Cells(t, "C") & Cells(t, "D")
ara2(t) = 1
Next

say = 3
For i = 2 To son
say2 = 0
veri = ""
For j = 2 To son
bulunan = Cells(j, "A") & Cells(j, "B") & Cells(j, "C") & Cells(j, "D")

If ara2(j) = 1 Then
If ara1(i) = bulunan Then
veri = veri & "_" & j
sat = sat + 1
If sat > 1 Then
ara2(j) = 0

Range(Cells(j, "A"), Cells(j, "e")).Interior.ColorIndex = say
Range(Cells(i, "A"), Cells(i, "e")).Interior.ColorIndex = say

Cells(j, "j") = say
Cells(i, "j") = say
Cells(j, "k") = j & "_" & i

say2 = 1
End If
End If
End If

Next j

deg1 = Split(Mid(veri, 2, 10), "_")
If UBound(deg1) > 0 Then
Cells(i, "L") = Mid(veri, 2, Len(veri) - 1)
For k = 0 To UBound(deg1)
Cells(deg1(k), "M") = Mid(veri, 2, Len(veri) - 1)
Next k
End If

sat = 0
If say2 = 1 Then
say = say + 1
If say = 56 Then say = 3
End If
Next i

Application.ScreenUpdating = True
MsgBox "işlem tamam"
End Sub

cems · 25 Nisan 2019

Sayın Halit3 hocam,
Son kodları denedim soran adına ; ilk anda dosya adı sorun oldu, bunu aaa olarak değiştirdiğimde
" Birleştirilmiş hücrenin bir parçası değiştirilemez " hatası verdi, ancak birleşmeyi göremedim de çalışmadığı için ...

halit3 · 25 Nisan 2019

I3:K5 hücresi birleştirilmiş bunu çöz kod çalışır.

cems · 25 Nisan 2019

Gözümün önünde olanı görememişim

Bu arada böylesine bir kod şiiri nasıl yazdığınızı da çok merak ediyorum, zira tek satırına dokunmaya dahi kıyamadan kodları okuyorum

http://www.filebig.net/files/Auj4zvacMT

İki Liste Karşılaştırma {6 Farklı Mükerrer Bulma}

gicimi

Ekli dosyalar

cems

Ekli dosyalar

gicimi

gicimi

cems

cems

gicimi

cems

unilll

cems

unilll

cems

unilll

halit3

Uzman

halit3

Uzman

cems

Ekli dosyalar

halit3

Uzman

cems

halit3

Uzman

cems

Ekli dosyalar