كود ترحيل عند تحقق شرط

[عبدالله حمود]

الاخوة الاعزاء 

 

لدي ملف مكون من عدد 2 اوراق عمل ولكن ارغب بترحيل بيانات معينة من ورقة عمل 1 الي ورقة عمل 2 عند تحقق شرط في ورقة عمل 1 ... 

 

دعمكم مع الشكر 

[ياسر خليل أبو البراء]

أخي الكريم ارفق ملفك ليسهل الوصول للمطلوب بشكل أفضل وأسرع

[عبدالله حمود]

مرفق لكم المطلوب...

كود الترحيل.rar

[ياسر خليل أبو البراء]

أخي الكريم عبد الله

يرجى تغيير اسم الظهور للغة العربية

كما يرجى مستتقبلاً شرح المطلوب في الموضوع نفسه وليس داخل الملف فحسب

إليك الكود التالي عله يكون المطلوب

Sub TransferData()
    Dim WS As Worksheet, SH As Worksheet
    Dim Cel As Range, LR As Long, CounterID As Long
    Set WS = Sheets("Sheet1"): Set SH = Sheets("Sheet2")
    
    Application.ScreenUpdating = False
        For Each Cel In WS.Range("C2:C" & WS.Cells(Rows.Count, "C").End(xlUp).Row)
            If Cel.Value = "موافق علية " And Cel.Offset(, 1).Value = "برنامج تدريبي" Then
                CounterID = Application.WorksheetFunction.CountIf(SH.Range("B4:B" & SH.Cells(Rows.Count, "B").End(xlUp).Row), Cel.Offset(, -1))
                If CounterID >= 1 Then MsgBox "هذا الاسم أو رقم الهوية موجود من قبل" & vbCrLf & Cel.Offset(, -2) & vbTab & vbTab & Cel.Offset(, -1), 64: GoTo Skipper
                Cel.Offset(, -2).Resize(, 2).Copy
                LR = SH.Cells(Rows.Count, "A").End(xlUp).Row + 1
                SH.Range("A" & LR).PasteSpecial xlPasteValues
            ElseIf Cel.Value = "موافق علية " And Cel.Offset(, 1).Value = "برنامج توظيف" Then
                CounterID = Application.WorksheetFunction.CountIf(SH.Range("J4:J" & SH.Cells(Rows.Count, "J").End(xlUp).Row), Cel.Offset(, -1))
                If CounterID >= 1 Then MsgBox "هذا الاسم أو رقم الهوية موجود من قبل" & vbCrLf & Cel.Offset(, -2) & vbTab & vbTab & Cel.Offset(, -1), 64: GoTo Skipper
                Cel.Offset(, -2).Resize(, 2).Copy
                LR = SH.Cells(Rows.Count, "I").End(xlUp).Row + 1
                SH.Range("I" & LR).PasteSpecial xlPasteValues
            End If
Skipper:
            CounterID = 0
        Next Cel
        MsgBox "تمت عملية الترحيل بعون الله", 64
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

تقبل تحياتي

Transfer Data To Another Sheet Skipping Duplicates YasserKhalil.rar

[عبدالله حمود]

الله يعطيك العافية اخي ابوالبراء علي هذا المجهود ... ولكن ارغب منكم اضافة شي اخر التي وهي عندما تكون الاسماء الموجود في ورقة عمل 2 مكرره لا حاجة لاظهار الاسم عند عملية الترحيل ويكتفي بظهور عبارة لاتوجد بيانات جديدة  وفي حال هناك اسم جديد حسب الشروط يتم الاشعار بانه تم الترحيل بنجاح .. اي بمعني اخر لو افترضنا بان لدي قائمة باسماء كثيرة وعند الضغط علي الكود سيستغرق مني الموافقة علي اشعار بمعلومة ان هؤلاء الاشخاص  موجودين من قبل ... اتمني وصول الفكرة لديكم ...  

 

مع جزيل الشكر والتقدير علي تعاونك ...

[عبدالله حمود]

دعمكم وفقكم الله 

[وائل احمد المصري]

بعد أذن اخويا خالد تم عمل تعديل بسيط على الكود عله يكون المطلوب

Transfer Data To Another Sheet Skipping Duplicates YasserKhalil.rar