Mükerrer kayıtları blok halinde silme ?

[Gorarr]

Selamlar öncelikle konuyu araştırdım. Basit bulur yaparım sandım ama bulduğum kodları malesef kullanamadım, ya çok kompleks çıktı yada düzeltemediğim hatalar verdi o yüzden konuyu açtım.

Yapmaya çalıştığım;

A ve B sütununda mükerrer olan kayılatların ortadan kalkması ve sütunların birbirinden bağımsız bir şekilde alfebetik olarak sıralanması.

Yardımlarınız için şimdiden teşekküler.

 

[İhsan Tank]

Selamlar öncelikle konuyu araştırdım. Basit bulur yaparım sandım ama bulduğum kodları malesef kullanamadım, ya çok kompleks çıktı yada düzeltemediğim hatalar verdi o yüzden konuyu açtım.

Yapmaya çalıştığım;

A ve B sütununda mükerrer olan kayılatların ortadan kalkması ve sütunların birbirinden bağımsız bir şekilde alfebetik olarak sıralanması.

Yardımlarınız için şimdiden teşekküler.

merhaba

Sub müksil_sırala()
For sil = [A65536].End(3).Row To 1 Step -1
If WorksheetFunction.CountIf(Range("A1:A" & sil), Range("A" & sil)) > 1 Then Range("A" & sil).Resize(1, 1).ClearContents
Next
For sil = [B65536].End(3).Row To 1 Step -1
If WorksheetFunction.CountIf(Range("B1:B" & sil), Range("B" & sil)) > 1 Then Range("B" & sil).Resize(1, 1).ClearContents
Next
Range("A:A").Sort key1:=Range("A1"), ORDER1:=xlAscending
Range("B:B").Sort key1:=Range("B1"), ORDER1:=xlAscending
End Sub

bu işinizi görür mü_?

 

[Gorarr]

İhsah hocam teşekkür ederim ama anlayamadığım bir şekilde B sütununda fazladan silme yapıyor. ( B sütununda 11 farklı yazı var ama silme sonrası 7 tane kalıyor). Tekrar bakmanız mümkünmü. saygılar.

 

[Gorarr]

Sub müksil_sırala()
For sil = [A65536].End(3).Row To 1 Step -1
If WorksheetFunction.CountIf(Range("A1:A" & sil), Range("A" & sil)) > 1 Then Range("A" & sil).Resize(1, 1).ClearContents
Next
For sil = [B65536].End(3).Row To 1 Step -1
If WorksheetFunction.CountIf(Range("B1:B" & sil), Range("B" & sil)) > 1 Then Range("B" & sil).Resize(1, 1).ClearContents
Next
Range("A:A").Sort key1:=Range("A1"), ORDER1:=xlAscending
Range("B:B").Sort key1:=Range("B1"), ORDER1:=xlAscending
End Sub

Hocam şu kısımlardaki "7" yi "1" yaptım sorun halloldu. VB bilgim henüz yetersiz o yüzden değiştirdiğim kodun mantığını anlayamadım.

Tekrar teşekküler. selamlar saygılar...

 

[İhsan Tank]

Hocam şu kısımlardaki "7" yi "1" yaptım sorun halloldu. VB bilgim henüz yetersiz o yüzden değiştirdiğim kodun mantığını anlayamadım.

Tekrar teşekküler. selamlar saygılar...

sorunu çözmüşsünüz bende üstteki kod'u güncelledim.

 

[Korhan Ayhan]

Selamlar,

Alternatif olarak aşağıdaki koduda kullanabilirsiniz. Silme işlemini blok halinde yapar.

Option Explicit
 
Sub MÜKERRERLERİ_SİL_SIRALA()
    Dim X As Long, ALAN As Range
 
    Application.ScreenUpdating = False
 
    Columns("A:A").Sort Key1:=Range("A1"), Order1:=xlAscending
    Columns("B:B").Sort Key1:=Range("B1"), Order1:=xlAscending
 
    For X = Cells(Rows.Count, 1).End(3).Row To 1 Step -1
        If WorksheetFunction.CountIf(Range("A1:A" & X), Cells(X, 1)) > 1 Then
            If ALAN Is Nothing Then
                Set ALAN = Range(Cells(X, 1).Address)
            Else
                Set ALAN = Union(ALAN, Range(Cells(X, 1).Address))
            End If
        End If
    Next
 
    If Not ALAN Is Nothing Then ALAN.Delete [COLOR=red]Shift:=xlUp[/COLOR]
 
    Set ALAN = Nothing
 
    For X = Cells(Rows.Count, 2).End(3).Row To 1 Step -1
        If WorksheetFunction.CountIf(Range("B1:B" & X), Cells(X, 2)) > 1 Then
            If ALAN Is Nothing Then
                Set ALAN = Range(Cells(X, 2).Address)
            Else
                Set ALAN = Union(ALAN, Range(Cells(X, 2).Address))
            End If
        End If
    Next
 
    If Not ALAN Is Nothing Then ALAN.Delete [COLOR=red]Shift:=xlUp[/COLOR]
    Range("A1").Select
 
    Application.ScreenUpdating = True
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[Gorarr]

Korhan hocam sizede çok teşekkürler. Ellerinize sağlık bu kodlarıda kaydettim.

 

[Korhan Ayhan]

Selamlar,

Üstteki mesajımdaki koda kırmızı renkle belirttiğim eklemeleri yaptım. Lütfen son halini kullanınız.

 

[Gorarr]

Çok teşekkür ederim , son halini aldım.