T4252_Transfer To Another Workbook Prevent Duplicates

https://excel-egy.com/forum/t4252
---------------------------------

Sub Transfer_To_Another_Workbook_Prevent_Duplicates()
    Dim wb As Workbook, ws As Worksheet, nextRow As Long, lastRow As Long

    Const wbName As String = "الصادر"
    Const source As String = "قاعدة البيانات"
    Const target As String = "الصادر العام"
    Const shCert As String = "الشهادة"

    With Application
        .ScreenUpdating = False: .DisplayAlerts = False: .AskToUpdateLinks = False
    End With
        On Error Resume Next
            Set wb = Workbooks(wbName & ".xlsm")
            Set ws = ThisWorkbook.Sheets(source)
            nextRow = ws.ListObjects(1).Range.Columns(3).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

            If wb Is Nothing Then
                Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & wbName & ".xlsm")
            Else
                wb.Activate
            End If
        On Error GoTo 0

        With wb.Sheets(target)
            If Application.WorksheetFunction.CountIf(.ListObjects(1).ListColumns(6).DataBodyRange, ws.Range("M" & nextRow).Value) >= 1 Then MsgBox "Duplicate", vbExclamation: GoTo Skipper
            lastRow = .ListObjects(1).Range.Columns(3).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
            .Range("C" & lastRow).Value = Format(Date, "yyyy/mm/dd")
            .Range("D" & lastRow).Value = "طلاب"
            .Range("E" & lastRow).Value = ws.Range("E" & nextRow).Value
            .Range("G" & lastRow).Value = ws.Range("M" & nextRow).Value
            .Range("C" & lastRow).Select
            ActiveWorkbook.Save
            Windows(ThisWorkbook.Name).Activate
        End With

        Sheets(shCert).Select
        ExecuteExcel4Macro "PRINT(1,,,1,,,,,,,,2,,,TRUE,,FALSE)"
        Sheets(source).Select
        Range("C" & [C2].End(xlDown).Row + 1).Select
        ActiveWorkbook.Save
Skipper:
    With Application
        .ScreenUpdating = True: .DisplayAlerts = True: .AskToUpdateLinks = True
    End With
End Sub