Soru Aktarılan satır kadar uyarı verme

[sirkülasyon]

Private Sub CommandButton1_Click()
On Error Resume Next
Application.ScreenUpdating = False
Dim s1 As Worksheet, S2 As Worksheet
Dim sS1 As Integer, sS2 As Integer
Dim Son As Long
Set s1 = ThisWorkbook.Worksheets("Bordro")
Set S2 = ThisWorkbook.Worksheets("ARŞİV")
sS1 = s1.Range("A" & Rows.Count).End(xlUp).Row
sS2 = S2.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To sS1
a1 = s1.Range("D" & i).Value
a2 = s1.Range("E" & i).Value
a3 = s1.Range("F" & i).Value
a4 = s1.Range("T" & i).Value
a5 = s1.Range("U" & i).Value
Mukerrer_Kontrol
If Mukerrer = False Then
'---------------------------------------------------------
    Son = s1.Cells(s1.Rows.Count, 1).End(3).Row

    If Son > 1 Then
        s1.Range("A2:X" & Son).Copy
        With S2.Cells(S2.Rows.Count, 1).End(3)(2, 1)
            .PasteSpecial xlValues
            .PasteSpecial xlFormats
        End With
        S2.Range("A2:Z" & S2.Rows.Count).Sort S2.Range("A2"), xlAscending
        S2.Select
        S2.Range("A1").Select
        s1.Select
        Application.CutCopyMode = False
        Application.ScreenUpdating = True
        MsgBox "Veri aktarımı tamamlanmıştır.", vbInformation
    Else
        Application.ScreenUpdating = True
        MsgBox "Aktarılacak veri bulunamadı!", vbExclamation
    End If
      End If
    Set s1 = Nothing
    Set S2 = Nothing
Next
End Sub

Sub Mukerrer_Kontrol()
Dim S2 As Worksheet
Dim sS2 As Integer
Set S2 = ThisWorkbook.Worksheets("ARŞİV")
sS2 = S2.Range("B" & Rows.Count).End(xlUp).Row
Mukerrer = False
    For ii = 2 To sS2
    If S2.Range("D" & ii).Value = a1 Then
        If S2.Range("E" & ii).Value = a2 Then
            If S2.Range("F" & ii).Value = a3 Then
                If S2.Range("T" & ii).Value = a4 Then
                    If S2.Range("U" & ii).Value = a5 Then
                    MsgBox "Mükerrer kayıt tespit edildi", vbInformation + vbOKOnly, "HATIRLATMA"
                    Mukerrer = True
                        Exit Sub
                    End If
                End If
            End If
        End If
    End If
    Next
End Sub

Yukarıda ki kodda
MsgBox "Veri aktarımı tamamlanmıştır.", vbInformation
MsgBox "Mükerrer kayıt tespit edildi", vbInformation + vbOKOnly, "HATIRLATMA"
satırlar aktarılan satır kaç tane ise o kadar uyarı veriyor. (10 satır ise 10 kere uyarı veriyor. ) Bu uyarıyı her satır için değil de bir kere uyarı verecek şekilde nasıl düzeltebilirim?
Saygıyla

 

[necati]

Merhaba,
Mesaj satırını "Next" satırının hemen altına taşıman yeterli.

 

[sirkülasyon]

Uyguladım ama olmadı.
Listview üzerinden ARŞİV sayfasına aktarmak istiyorum. (D,E,F,T,U) sütunları aynı ise mükerrer olanları aktarmayacak. Rica etsem bakabilir misiniz.

 

[YUSUF44]

Yapacağınız basit bir işlemi çok gereksiz uzatmışsınız. Aktar düğmesindeki kodları aşağıdaki şekidle değiştirip deneyin. Mükerrer kontrol kodlarına gerek yok:

Private Sub CommandButton1_Click()
Dim s1 As Worksheet, S2 As Worksheet
Dim sS1 As Integer, sS2 As Integer
Dim Son As Long
Set s1 = ThisWorkbook.Worksheets("Bordro")
Set S2 = ThisWorkbook.Worksheets("ARŞİV")
sS1 = s1.Range("A" & Rows.Count).End(xlUp).Row
sS2 = S2.Range("A" & Rows.Count).End(xlUp).Row
veri = 0
For i = 2 To sS1
    If WorksheetFunction.CountIfs(S2.Range("D1:D" & sS2), s1.Cells(i, "D"), S2.Range("E1:E" & sS2), s1.Cells(i, "E"), _
                                    S2.Range("F1:F" & sS2), s1.Cells(i, "F"), S2.Range("T1:T" & sS2), s1.Cells(i, "t"), _
                                    S2.Range("U1:U" & sS2), s1.Cells(i, "U")) = 0 Then
        Application.ScreenUpdating = False
            veri = veri + 1
            s1.Range("A" & i & ":X" & i).Copy
            With S2.Cells(sS2 + 1, "A")
                .PasteSpecial xlValues
                .PasteSpecial xlFormats
            End With
            S2.Range("A2:Z" & sS2 + 1).Sort S2.Range("A2"), xlAscending
            S2.Select
            S2.Range("A1").Select
            s1.Select
            Application.CutCopyMode = False
        Application.ScreenUpdating = True
    End If
Next
If veri = 0 Then
    MsgBox "Aktarılacak veri bulunamadı!", vbExclamation
    Application.ScreenUpdating = True
Else
    MsgBox veri & " adet veri aktarıldı!", vbInformation
End If
Set s1 = Nothing
Set S2 = Nothing
End Sub

 

[sirkülasyon]

Teşekkür ederim Yusuf abi. Ellerine sağlık

 

[sirkülasyon]

Yusuf Abi
Bazen aktarırken satırın birini aktarıyor diğerini aktarmıyor.

 

[YUSUF44]

Mükerrer olabilir mi?

 

[sirkülasyon]

Mükerrer olayı değil abi. Aktaracağım sayfada henüz veri yok iken aktar dediğimde ilk satırı aktarıyor. Tekrar aktarma yaptığım zaman tamamını aktarıyor.

 

[YUSUF44]

With S2.Cells(sS2 + 1, "A")

satırını

With S2.Cells(sS2 + veri, "A")

olarak değiştirip deneyin.

 

[sirkülasyon]

Yusuf Abi
Tamamdır. Ellerine Sağlık