Aynı olan veriyi silerken belirlenen satırı silme.

[Kavinsky]

Öncelikle merhabalar. Yinelenenleri kaldır , koşullu biçimlendirme vs gibi fonksiyonlar tam istediğim şeyi karşılamadılar.Benim istediğim şey şudur; J sütununa yapıştırdığım numaraları H ve F sütunlarıyla kıyaslasın şayet J sütunundaki rakamın H ya da F de aynısını bulur ise o bulduğu satırı I ya kadar silsin. Örnek vermek gerekirse J3 te belirttiğim numarayı F113 te buldu. A113 ten başlasın I113'e kadar silsin ve alttaki satırları yukarı taşısın ki sildiğim satırda boşluk ya da düzeni bozan bir şey olmasın. Çünkü numaralar karışırsa içinden iyice çıkamam. Böyle bir imkan var mıdır?Teşekkür ederim.

 

[Mdemir63]

Selamlar
Yapmak istediğinizi yazmışsınız ancak örnek bir dosya olursa daha çabuk yanıt alırsınız.

iyi çalışmalar


http://s3.dosya.tc/

 

[Kavinsky]

Kontrol sütunundaki veriyi (örnek J2) Tüm F veH yani 1. ve 2. no sütunu içinde aratsın şayet var ise ikisinden birinde ya da ikisinde de olur farketmez o bulduğu satırı I satırına kadar silsin (I dahil). Teşekkür ederim.

http://s3.dosya.tc/server12/rmrcqe/Kitap1.xlsx.html

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Sil()
    Dim Bul As Range, Adres As String, Alan As Range, Silinecek_Satirlar As Range
    Dim X As Long, Son As Long, SayF As Long, SayH As Long
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Son = Cells(Rows.Count, "A").End(3).Row
    
    For X = 2 To Son
        If Cells(X, "J") <> "" Then
            SayF = WorksheetFunction.CountIf(Range("F:F"), Cells(X, "J"))
            SayH = WorksheetFunction.CountIf(Range("H:H"), Cells(X, "J"))
            If SayF > 0 Then
                Set Alan = Range("F:F")
            ElseIf SayH > 0 Then
                Set Alan = Range("H:H")
            End If
            
            If Not Alan Is Nothing Then
                Set Bul = Alan.Find(Cells(X, "J"), , , xlWhole)
                If Not Bul Is Nothing Then
                    Adres = Bul.Address
                    Do
                        If Silinecek_Satirlar Is Nothing Then
                            Set Silinecek_Satirlar = Range("A" & Bul.Row & ":I" & Bul.Row)
                        Else
                            Set Silinecek_Satirlar = Application.Union(Silinecek_Satirlar, Range("A" & Bul.Row & ":I" & Bul.Row))
                        End If
                        
                        Set Bul = Alan.FindNext(Bul)
                    Loop While Not Bul Is Nothing And Bul.Address <> Adres
                End If
            End If
        End If
    Next
    
    If Not Silinecek_Satirlar Is Nothing Then
        Silinecek_Satirlar.Delete xlUp
        
        Application.ScreenUpdating = True
        Application.Calculation = xlCalculationAutomatic
        MsgBox "İşleminiz tamamlanmıştır.", vbInformation
    Else
        Application.ScreenUpdating = True
        Application.Calculation = xlCalculationAutomatic
        MsgBox "Silinecek kayıt bulunamadı!", vbInformation
    End If
End Sub

 

[Kavinsky]

Üstadım ellerinize sağlık . Tam kafamdaki şey oldu , emekleriniz için teşekkür ederim.