اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

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


إذهب إلى أفضل إجابة Solved by سليم حاصبيا,

الردود الموصى بها

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

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

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

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

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

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

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

ملاحظة :الارقام يقوم بجلبها من الشيت رقم 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

  • Like 2
رابط هذا التعليق
شارك

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

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

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

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

Capture.JPG

رابط هذا التعليق
شارك

  • أفضل إجابة

تم التعديل على الماكرو لكن يجب ادراج جدول للاسعار  حتى يعمل الماكرو بشكل جيد  (العامود  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

رابط هذا التعليق
شارك

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

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

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

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

رابط هذا التعليق
شارك

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



سجل دخولك الان
  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information