Mükerrer plakaları aktarma

[ASLAN7410]

Merhaba hayırlı akşamlar.

Ekte gönderdiğim excel dosyamın 1.sayfasında B2 ile AE2 sütunları arasında değişik
zamanlarda sistemden alınan yaklaşık 1000'e yakın plaka var.

Yapmak istediğim butona bastığımda 1.sayfada sütunlardaki mükerrer plakaları 2.sayfaya
aktarmak istiyorum yardımcı olur musunuz? (Örnekteki plakalar atmasyondur.)

http://dosya.co/cb17y2hvkqsb/ÖRNEK1.xlsm.html
.

 

[Ömer BARAN]

Merhaba, aşağıdaki gibi olabilir.

Kırmızı renklendirdiğim satır Sayfa2'de önceden yazılmış verileri siler.
Eski kayıtları silmeden, mevcut listenin altına devam etmek isterseniz kırmızı renklendirdiğim satırı silin.
.

[B]Sub MUKERRER()[/B]
Set s1 = Sheets("Sayfa1"): Set s2 = Sheets("Sayfa2")
[COLOR="Red"]If s2.Cells(Rows.Count, 1).End(3).Row > 1 Then s2.Range("A2:C" & Rows.Count).ClearContents[/COLOR]
For Each hcr In s1.Range("B2:AE" & s1.Cells(Rows.Count, 1).End(3).Row)
    adet = WorksheetFunction.CountIf(s1.Range("B2:AE" & s1.Cells(Rows.Count, 1).End(3).Row), hcr)
    If hcr.Value <> "" And adet > 1 And WorksheetFunction.CountIf(s2.[C:C], hcr) = 0 Then
        s2sat = s2.Cells(Rows.Count, 1).End(3).Row + 1
        hcr.Interior.Color = vbRed
        s2.Cells(s2sat, 1) = s2sat - 1: s2.Cells(s2sat, 2) = adet: s2.Cells(s2sat, 3) = hcr.Value
    End If
Next
MsgBox "Mükerrer olan plakalar, " & s2.Name & " isimli sayfaya aktarıldı.", , "..:: Ömer BARAN ::.."
[B]End Sub[/B]

 

[ASLAN7410]

Sayın Ömer Bey, ellerinize sağlık, çok teşekkür ediyorum.

Tam istediğim gibi çalışıyor, hayırlı akşamlar, hayırlı çalışmalar diliyorum.

 

[Ömer BARAN]

İyi çalışmalar dilerim.