كود عدم تكرار الرقم الوظيفى فى جلب البيانات وزيادة بياناته على الرقم الموجود مسبقاً

[ahmed almajbry]

السلام عليكم ورحمة الله وبركاتة

اعضاء وفريق  منتدي اوفيسنا الغالي  

  اريد اضافة بسيطة على الملف المرفق حيث عندما اضيف رقم مكرر

وتخرج رساله تفيد بأن هل تريد اضافتة ( نعم او لا ) المطلوب عندما اكتب نعم

لااريدة ان يكرر اضافة الرقم والاسم بل اريده ان يزيد عدد الرحلات ويضعف قيمة الوجبة

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

ارجو ان اكون قد اوصلت الفكره 

ملاحظة :الارقام يقوم بجلبها من الشيت رقم 2 وعدد الرحلات وبدل الوجبة يتم اضافتها يدويا حاليا 

واشكركم جزيل الشكر على كل ما تقدمو في هذا المنتدي المميز 

بدل وجبة رحلات 0000الباص.xlsm

[سليم حاصبيا]

جرب هذا الماكرو

Private Sub Worksheet_Change(ByVal Target As Range)
    Application.EnableEvents = False
    Dim add_ro As Long
    Dim son As Long
    Dim Match, cont%
    son = Cells(Rows.Count, "A").End(xlUp).Row
    If Intersect(Target, Range("A9:A" & son + 1)) Is Nothing Or _
     Target.Count > 1 Then GoTo ExiT_me
     
     On Error Resume Next

     Match = Application.Match(Target, Sheets("sheet2").Range("A:A"), 0)

     If Match = 0 Then Target = vbNullString: GoTo ExiT_me
      On Error GoTo 0
      cont = Application.CountIf(Sheets("sheet1").Range("A9:A" & son), Target)
       If cont = 1 Then
      '=============================
       Cells(Target.Row, 2) = Sheets("sheet2").Cells(Match, 2)
       Cells(Target.Row, 3) = Sheets("sheet2").Cells(Match, 3)
       '=========================
       Else
        add_ro = Application.Match(Target, Sheets("sheet1").Range("A:A"), 0)
        Cells(add_ro, 3) = Cells(add_ro, 3) + Sheets("sheet2").Cells(Match, 3)
        Target = vbNullString
      End If
ExiT_me:
Application.EnableEvents = True
End Sub

الملف مرفق

RAHARAT.xlsm

[ahmed almajbry]

السلام عليكم استاذي الفاضل سليم حصيبا 

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

ارجو ان اكون اوضحت الطلب جيدا  

واشكرك جزيل الشكر 

[ahmed almajbry]

استاذي سليم وكل اساتذهالموقع انتظر ردا منكم 

[سليم حاصبيا]

تم التعديل على الماكرو لكن يجب ادراج جدول للاسعار  حتى يعمل الماكرو بشكل جيد  (العامود  E يمكن اخفاءه اذا كنت تريد )

Private Sub Worksheet_Change(ByVal Target As Range)
Rem =======>> CREATETED BY SALIM HASBAYA ON 10/8/2019
    Application.EnableEvents = False
    Dim add_ro As Long
    Dim son As Long
    Dim Match%, cont%
    son = Cells(Rows.Count, "A").End(xlUp).Row
    Dim last_ro%
    If Intersect(Target, Range("A9:A" & son + 1)) Is Nothing Or _
     Target.Count > 1 Then GoTo ExiT_me
     
     On Error Resume Next

     Match = Application.Match(Target, Sheets("sheet2").Range("A:A"), 0)

     If Match = 0 Then _
      MsgBox " This Number Not Found": _
      Target = vbNullString: GoTo ExiT_me
      On Error GoTo 0
      cont = Application.CountIf(Sheets("Sheet1").Range("A9:A" & son), Target)
       If cont = 1 Then
      '=============================
       Cells(Target.Row, 2) = Sheets("sheet2").Cells(Match, 2)
       Cells(Target.Row, 3) = 1
       '=========================
       Else
        add_ro = Application.Match(Target, Sheets("Sheet1").Range("A:A"), 0)
        Cells(add_ro, 3) = Cells(add_ro, 3) + 1
        Target = vbNullString
      End If
   last_ro = Cells(Rows.Count, "A").End(xlUp).Row
    Range("D9:d" & last_ro).Formula = "=IF(N($E9)<=0,0,$E9*$C9)"
ExiT_me:
Application.EnableEvents = True
End Sub

الملف من جديد

RAHARAT_NEW.xlsm

[ahmed almajbry]

بارك الله فيك استاذي سليم حاصيبا هذا ما كنت اريد بالظبط

اسأل الله العظيم ان يجعل هذا العمل فى ميزان حسنات

اشكرك جزيل الشكر واشكر كل القائمين على هذا المنتدي الاكثر من رائع

حفظكم الله  وكل عام وانتم بخير