Tekrar Rakam Eleme

[adslboy]

Merhaba Arkadaslar,

yapmak istedigimi asagiya yazdim yardimci olucak Degerli Hocalar ve Ustad Arkadaslara tesekurler .. :hey:

 

[Kemal Demir]

Merhaba,

Aşagıdaki kod zannedersem işinizi görür

Sub kontrol()
For y = 1 To 10
For x = 1 To [a65536].End(3).Row
ara = WorksheetFunction.CountIf(Range("a" & x & ":" & " j" & x), Cells(x, y))
If ara > 1 Then
Cells(x, 11) = Cells(x, y) & "-" & Cells(x, 11)
Cells(x, y) = ""
End If
Next
Next
End Sub

NOT : Doğru olan çözüm , Evren Bey'in çözümüdür.
Ben işlemi yaptırdıgımda sadece çiftleri sildirip çift olan verileri yazdırıyorum.Renklendirme işlemi yok

 

[Orion1]

Dosyanız ekte.

Sub karsilastir()
Dim i As Long, k As Integer, sut As Byte
Range("K1:T65536").ClearContents
For i = 1 To 500
    sut = 11
    For k = 10 To 1 Step -1
        If Cells(i, k).Value <> "" Then
            If WorksheetFunction.CountIf(Range("A" & i & ":J" & i), Cells(i, k).Value) > 1 Then
                Cells(i, sut).Value = Cells(i, k).Value
                Cells(i, k).ClearContents
                sut = sut + 1
            End If
        End If
    Next k
Next i
MsgBox "İşlem bitti."
End Sub

 

[Kemal Demir]

Evren hocam,

Aynı anda "Enter" lamışız.

Yok yok ben birkaç işlem daha yaptım.

 

[adslboy]

Emeği geçen her iki hocamada sonsuz teşekkur ederım

her iki calisma da guzel olmus :icelim:

 

[Orion1]

Emeği geçen her iki hocamada sonsuz teşekkur ederım

her iki calisma da guzel olmus :icelim:

Rica ederim.
İyi çalışmalar.