Mükerrer Kayıtları İşaretlemek

[nur_u_allah]

Sayın hocalarım ve excele gönül verenler bir sıkıntım var.
B sütünundaki abone numaralarının aynı olanlarını işaretlemek istiyorum tabi ilk mükerrer girililenide işaretletmek istiyorum.
B sütununda bulunan mükerrerleri bulunan satırın sağındaki ve solundaki verileride sayfa 2 ye aktarmak istiyorum.
Saygılarımla

 

[Ömer]

Merhaba,

Linki inceleyiniz..

Mükerrer (Çift) Kayıt Engelleme,Sayma Örnekleri

.

 

[nur_u_allah]

Ömer bey baktım örneklerin hepsini inceledim ama biir türlü uygulamayadım.

 

[usubaykan]

Merhaba;

Aşağıdaki kodu dener misiniz?

Option Explicit
Sub mükrerrer_kayıt()
Dim Bul As Range, Adres As String, S1 As Worksheet, S2 As Worksheet, _
Satır As Long, U As Long, Say As Double
Set S1 = Sheets("Sayfa1")
Set S2 = Sheets("Sayfa2")
'S2.Range("A2:D65536").Clear
For U = 2 To S1.Range("C65536").End(3).Row
    Set Bul = S1.Range("C:C").Find(What:=S1.Cells(U, "C"), lookat:=xlWhole)
    Say = WorksheetFunction.CountIf(S2.Range("C:C"), Bul)
    If Say = 0 Then
        Satır = S2.Range("A65536").End(3).Row
        If Not Bul Is Nothing Then
            Adres = Bul.Address
                Do
                Satır = Satır + 1
                S2.Cells(Satır, "A") = S1.Cells(Bul.Row, "A")
                S2.Cells(Satır, "B") = S1.Cells(Bul.Row, "B")
                S2.Cells(Satır, "C") = S1.Cells(Bul.Row, "C")
                S2.Cells(Satır, "D") = Bul.Address
                Cells(Satır, "D").Select
                Set Bul = S1.Range("C:C").FindNext(Bul)
            Loop While Not Bul Is Nothing And Bul.Address <> Adres
        End If
    End If
Next
MsgBox "İşlem tamamlanmıştır."
End Sub

 

[muygun]

Merhaba;
Ömer beyin verdiği link oldukça dolgun örnekler mevcutu.
Sorunu sonuçlandıramadıysanız eki inceleyin.
İyi çalışmalar.

 

[usubaykan]

Merhaba;
Alternatif olarak aşağıdaki kodu sayfanızın kod bölümüne yazıp deneyiniz.

Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Son_Satır As Long, Son_Satır2 As Long, Say As Double
    
    If Intersect(Target, [C2:C65536]) Is Nothing Then Exit Sub
    If Target.Count > 1 Then Exit Sub
    Say = WorksheetFunction.CountIf(Sheets("Sayfa2").Range("C:C"), Target)
    If Say = 0 Then
    [C2:C10000].FormatConditions.Delete
    [C2:C10000].FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="=" & "" & Target & ""
    [C2:C10000].FormatConditions(1).Interior.ColorIndex = 45
    
    Range("C1").AutoFilter Field:=3, Criteria1:=Target
    Son_Satır = Sheets("Sayfa1").Range("C65536").End(3).Row
    
    Range(Cells(1 + 1, "A"), Cells(Son_Satır, "C")).Copy
    Son_Satır2 = Sheets("Sayfa2").Range("A65536").End(3).Row
    
    Sheets("Sayfa2").Cells(Son_Satır2, "A").PasteSpecial
    Range("D1") = WorksheetFunction.CountIf(Range("C:C"), Target) & " Kayıt sayfa2'ye aktarıldı."
    Range("C1").AutoFilter
Else
MsgBox Target & " Verisi daha önce aktarılmıştır."
End If
End Sub

 

[nur_u_allah]

Merhaba;
Alternatif olarak aşağıdaki kodu sayfanızın kod bölümüne yazıp deneyiniz.

Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Son_Satır As Long, Son_Satır2 As Long, Say As Double
    
    If Intersect(Target, [C2:C65536]) Is Nothing Then Exit Sub
    If Target.Count > 1 Then Exit Sub
    Say = WorksheetFunction.CountIf(Sheets("Sayfa2").Range("C:C"), Target)
    If Say = 0 Then
    [C2:C10000].FormatConditions.Delete
    [C2:C10000].FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="=" & "" & Target & ""
    [C2:C10000].FormatConditions(1).Interior.ColorIndex = 45
    
    Range("C1").AutoFilter Field:=3, Criteria1:=Target
    Son_Satır = Sheets("Sayfa1").Range("C65536").End(3).Row
    
    Range(Cells(1 + 1, "A"), Cells(Son_Satır, "C")).Copy
    Son_Satır2 = Sheets("Sayfa2").Range("A65536").End(3).Row
    
    Sheets("Sayfa2").Cells(Son_Satır2, "A").PasteSpecial
    Range("D1") = WorksheetFunction.CountIf(Range("C:C"), Target) & " Kayıt sayfa2'ye aktarıldı."
    Range("C1").AutoFilter
Else
MsgBox Target & " Verisi daha önce aktarılmıştır."
End If
End Sub

Ekledim ama çalışmıyor

 

[usubaykan]

Merhaba;

Ekledeğim kod sayfanın SelectionChange Sadece "C" sütununda aktarmak istediğin veri üzerinde tıklatınca gerçekleşir.
#4 nolu mesajdaki kod ise butona atadığınızda ve butona her basışınızda çalışır. Siz #4 nolu mseajdaki kodu denediniz mi?