Farklı satır ve sütunda bulunan aynı veriden biri dışında diğerlerinin silinmesi.

[evrim_my]

Benim sorunum gelişigüzel sayıların yer aldığı bir tabloda aynı içeriğe sahip hücrelerden birini bırakıp diğerlerini silebilecek bir makro. Örnek olarak bir çalışma kitabı ekliyorum. Yardım edebilirseniz çok sevinirim.

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz.

Option Explicit
 
Sub MÜKERRER_OLANLARI_TEMİZLE()
    Dim ALAN As Range, HÜCRE As Range
    
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With
    
    Set ALAN = Range("A1:U30")
    
    For Each HÜCRE In ALAN
        If HÜCRE.Value <> "" And WorksheetFunction.CountIf(ALAN, HÜCRE.Value) > 1 Then
            HÜCRE.ClearContents
        End If
    Next
    
    Set ALAN = Nothing
    
    With Application
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[evrim_my]

Korhan bey teşekkürler. Kod çalışıyor ve de çok hızlı. Mükerrer kayıtların var olduğunu sınayan ve uyaran bir kod eklenebilir mi? Ben bu makro'yu başka bir makro'ya ekledim şimdi de şöyle bir sorun çıktı. Aralıkta ki değerler sayılırken boş hücreyi sıfır olarak sayıyor. Gerçekte bir tane sıfır var iken 193 gösteriyor.

 

[Korhan Ayhan]

Selamlar,

Üstteki mesajımdaki kodu güncelledim. İncelermisiniz.

 

[evrim_my]

Korhan bey ilginiz için teşekkürler. Sorunumu bir çalışma kitabı aracılığı ile anlatmaya çalıştım. yardım edebilirseniz sevinirim.

 

[Korhan Ayhan]

Selamlar,

Saydırma işlemini yaptığınız kodu verirmisiniz.

 

[evrim_my]

Dim xc As Range, j As Integer, tpl As Single, sy As Integer
For j = 9 To xy + 1
For Each xc In ALAN
If xc >= ws2.Cells(j, 1) And xc < ws2.Cells(j, 2) Then
tpl = tpl + xc
sy = sy + 1
End If
Next xc
ws2.Cells(j, 4) = tpl
ws2.Cells(j, 3) = sy
If tpl <> 0 Then
tpl = 0
End If
If sy <> 0 Then
sy = 0
End If
If ws2.Cells(j, 2) >= c Then GoTo ws
Next j

 

[Korhan Ayhan]

Selamlar,

Ben eklediğiniz kodu çalıştırmadım. Siz uygulama yaptığınız çalışır haldeki dosyanızı eklermisiniz.

 

[volkansam]

hocam bu verdıgınız kod harıka calısıyor
ancak sılmek yerıne mukerrer kayıtıtları ıstedıgımız renge boyatabılmemız mumkunmu
patron boyle bır sey arıyordu
sımdı sayenızde halledebılırsem cok ıyı olacak benım ıcın
ılgınıze tesekkur ederım

Option Explicit
 
Sub MÜKERRER_OLANLARI_TEMİZLE()
    Dim ALAN As Range, HÜCRE As Range
    
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With
    
    Set ALAN = Range("A1:U30")
    
    For Each HÜCRE In ALAN
        If HÜCRE.Value <> "" And WorksheetFunction.CountIf(ALAN, HÜCRE.Value) > 1 Then
            HÜCRE.ClearContents
        End If
    Next
    
    Set ALAN = Nothing
    
    With Application
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

End Sub

 

[Korhan Ayhan]

Selamlar,

Sn. volkansam,

Forumumuza hoşgeldiniz.

Kod içinde geçen "HÜCRE.ClearContents" ifadesini aşağıdaki şekilde değiştirirseniz mükerrer kayıtlar renklenir.

HÜCRE.Interior.ColorIndex = 3