• DİKKAT

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

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

gicimi

gicimi

Altın Üye
Katılım
3 Şubat 2008
Mesajlar
593
Excel Vers. ve Dili
Office 2016 Eng. 64 Bit
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.
 

Ekli dosyalar

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 ?
 

Ekli dosyalar

Son düzenleme:
@cems Teşekkür ederim. Hocam elinize sağlık
 
@cems A ve B sütunlarındaki Mükerrer olanları renklendirebilir miyiz. Ayrı Butonla yapabilir miyiz.
 
Onu unuttum , deniyorum ...
 
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
 
@cems ilginiz için teşekkür ederim. İyi geceler.(y)
 
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 :)
 
Merhabalar,

Bunu A B C D sütunları kontrol ederek yani aynı sütunda 4 sütunda yapmak mümkün mü?
 
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 ?
 
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
 
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?
Genişletmek için tıkla ...

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
 
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
 
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
 
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 ...
 
I3:K5 hücresi birleştirilmiş bunu çöz kod çalışır.
 
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
 

Ekli dosyalar

Son düzenleme:
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst