Mükerrer kayıt uyarısı

Ahmet Sami

Altın Üye
Katılım
10 Kasım 2006
Mesajlar
397
Excel Vers. ve Dili
microsoft office 2007-2010-2013-2019-2021
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
 

Ekli dosyalar

Ömer

Moderatör
Yönetici
Katılım
18 Ağustos 2007
Mesajlar
22,196
Excel Vers. ve Dili
Microsoft 365 Tr
Ofis 2016 Tr
Merhaba,

Deneyiniz.
Kod:
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

Altın Üye
Katılım
10 Kasım 2006
Mesajlar
397
Excel Vers. ve Dili
microsoft office 2007-2010-2013-2019-2021
Ömer bey çok teşekkür ederim.
 
Üst