Farklı sayfalarda mükerrer kayıt

[1ndependent]

Arkadaşlar merhaba.

Biliyorum bu başlık altında forumda bir çok konu var ama malesef kendime uygun olanını bulamadım.

Birden fazla sayfada kullanacağım 2 sütunda bulunan değeri eğer farklı bir sayfada yazdırırsam diğerlerini silmesini istiyorum

Örnek dosyada istediğimi dilimin döndüğünce anlattım, inşallah yardımcı olabilirsiniz.
Teşekkürler.

 

[Korhan Ayhan]

Deneyiniz.

BuÇalışmaKitabı (ThisWorkbook) bölümüne uygulayınız.

Option Explicit

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Dim Bul As Range, Adres As String, Alan As Range, Say As Long
    On Error GoTo Son
    If Not Intersect(Target, Range("B2:C" & Rows.Count)) Is Nothing Then
    If Cells(Target.Row, "B") <> "" And Cells(Target.Row, "C") <> "" Then
        For Each Sh In ThisWorkbook.Worksheets
            Set Bul = Sh.Range("B:B").Find(Cells(Target.Row, "B"), , , xlWhole)
            If Not Bul Is Nothing Then
                Adres = Bul.Address
                Do
                    If Bul.Offset(0, 1) = Cells(Target.Row, "C") Then
                        If Sh.Name = ActiveSheet.Name Then
                            If Cells(Target.Row, "B").Address <> Bul.Address Then
                                Say = Say + 1
                                If Alan Is Nothing Then
                                    Set Alan = Bul.Resize(1, 2)
                                Else
                                    Set Alan = Union(Alan, Bul.Resize(1, 2))
                                End If
                            Else
                                GoTo 10
                            End If
                        Else
                            Say = Say + 1
                            If Alan Is Nothing Then
                                Set Alan = Bul.Resize(1, 2)
                            Else
                                Set Alan = Union(Alan, Bul.Resize(1, 2))
                            End If
                        End If
                    End If
10                  Set Bul = Sh.Range("B:B").FindNext(Bul)
                Loop While Not Bul Is Nothing And Bul.Address <> Adres
            End If
            Application.EnableEvents = False
            If Not Alan Is Nothing Then Alan.ClearContents
            Set Alan = Nothing
            Set Bul = Nothing
            Adres = ""
        Next
    End If
    End If
Son:
    Application.EnableEvents = True
    If Say > 0 Then MsgBox Say & " adet mükerrer veri tespit edilip silinmiştir.", vbInformation
End Sub

 

[1ndependent]

Korhan bey Teşekkür ederim.

Ancak 1 küçük problem var gibi gözüküyor.
Mükerrer kayıtları siliyor ancak, If Not Intersect(Target, Range("B2:C" & Rows.Count)) Is Nothing Then
hatası veriyor.

 

[1ndependent]

Korhan bey Teşekkür ederim.

Ancak 1 küçük problem var gibi gözüküyor.
Mükerrer kayıtları siliyor ancak, If Not Intersect(Target, Range("B2:C" & Rows.Count)) Is Nothing Then
hatası veriyor.

Yardımcı olabilecek var mıdır acaba?

 

[Korhan Ayhan]

Nasıl bir işlem sonunda o satırda hata verdi.

 

[1ndependent]

Nasıl bir işlem sonunda o satırda hata verdi.

Sayfa1 de yazmış olduğum değerler ile Sayfa 2 de yazmış olduğum değerler aynı olduğunda bu hata mesajını verdi.

 

[Korhan Ayhan]

Üstteki mesajımda önerdiğim kodu revize ettim. Tekrar deneyiniz.

 

[1ndependent]

Çok teşekkür ederim, şimdi oldu.
Elinize sağlık.