Mükerrer kayıt uyarısı

[Ahmet Sami]

Daha önce burdan yardım aldığım bir konu ile ilgili olarak, Üstadlarım sizden ricam aktardığım verilerin tamamı aynı ise mükerrek kayıt olarak beni uyara bilirmi yani E9 : E19 arasındaki aynı olan verileri aktardığım zaman önce aktarmışsam aynı verileri tekrar kaydetmek istiyor musun diye beni uyarsın

 

[Ömer]

Merhaba,

Deneyiniz.

Sub Ekleeee()

    Application.ScreenUpdating = False

    Dim sonsat, S1 As Worksheet, S2 As Worksheet, i As Byte, c As Range, Adr As String, s As Byte

    Set S1 = Sheets("ANASAYFA")
    Set S2 = Sheets(S1.Range("E9").Value)
    
    Set c = S2.[A:A].Find(S1.[E10], , xlValues, xlWhole)
    If Not c Is Nothing Then
        Adr = c.Address
        Do
            s = 0
            For i = 11 To 18
                If S1.Cells(i, "E") = S2.Cells(c.Row, i - 9) Then
                    s = s + 1
                Else
                    Exit For
                End If
            Next i
            If s = 8 Then Exit Do
            Set c = S2.[A:A].FindNext(c)
        Loop While Not c Is Nothing And c.Address <> Adr
    End If
    
    sonsat = S2.Range("A65536").End(3).Row + 1
    If s = 8 Then
        sor = MsgBox("Mükerrer Kayıt! Devam Edeyim mi?", vbYesNo, "Veri Ekleme")
        If sor = vbYes Then
            S1.Range("E10:E18").Copy
            S2.Cells(sonsat, "A").PasteSpecial Paste:=xlPasteValues, Transpose:=True
            MsgBox (S1.Range("E9").Value & " Sayfasına veri eklendi")
        End If
    Else
        S1.Range("E10:E18").Copy
        S2.Cells(sonsat, "A").PasteSpecial Paste:=xlPasteValues, Transpose:=True
        MsgBox (S1.Range("E9").Value & " Sayfasına veri eklendi")
    End If
            
    Application.CutCopyMode = False
    Application.ScreenUpdating = False
    
    
End Sub

 

[Ahmet Sami]

Ömer bey çok teşekkür ederim.