Mükerrer olan ve olmayan

[tuncismet]

İyi günler,
A Sütununda bulunan verilerden mükerrer olanları B sütununa , Mükerrer olmayanları C sütununa aktarmak istiyorum.Teşekkürler.

 

[Ömer]

İyi günler,
A Sütununda bulunan verilerden mükerrer olanları B sütununa , Mükerrer olmayanları C sütununa aktarmak istiyorum.Teşekkürler.

Merhaba,

Örnek dosyayı incelermisiniz..

.

 

[Necdet]

Merhaba,

Aşağıdaki kodları dener misiniz?

Sub Karsilastir()
Dim i, j, k, Son As Long
Application.ScreenUpdating = False
Son = [A65536].End(3).Row
j = 0
k = 0
Range("B:C").ClearContents
For i = 1 To Son
    If Application.WorksheetFunction.CountIf(Range("A1:A" & Son), Cells(i, "A")) > 1 Then
        With Columns(2)
            Set c = .Find(Cells(i, "A"), LookIn:=xlValues)
            If c Is Nothing Then
            j = j + 1
            Cells(j, "B") = Cells(i, "A")
            End If
        End With
    Else
        k = k + 1
        Cells(k, "C") = Cells(i, "A")
    End If
Next i
Application.ScreenUpdating = True
End Sub

 

[Orion1]

Dosyanız ekte.

Sub mukerrer()
Dim hcr As Range, sat1 As Long, sat2 As Long
Sheets("Sayfa1").Select
Application.ScreenUpdating = False
Range("B1:C65536").ClearContents
For Each hcr In Range("A1:A" & Cells(65536, "A").End(xlUp).Row)
    If WorksheetFunction.CountIf(Range("A1:A" & hcr.Row), hcr.Value) = 1 Then
    If WorksheetFunction.CountIf(Range("A1:A65536"), hcr.Value) > 1 Then
        sat1 = sat1 + 1
        Cells(sat1, "B").Value = hcr.Value
        Else
        sat2 = sat2 + 1
        Cells(sat2, "C").Value = hcr.Value
    End If
    End If
Next
Application.ScreenUpdating = True
MsgBox "İşlem Tamam"
End Sub

 

[tuncismet]

İyi günler,
Sayın espiyonajl, Necdet Yeşertener ve Evren Gizlen verdiğiniz cevapların tamamı mükemmeldi. Sonsuz teşekkürler.