إضافة وخصم الكميات الواردة والصادرة مع كل إدخال جديد بعمود واحد

[أبو سجده]

بسم الله الرحمن الرحيم

وبه نستعين

إخوانى الافاضل

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

المرفق التالى عبارة عن إضافة قيم مع كل إدخال جديد بترحيلها للصفحة الرئيسية

المطلوب بحول الله تعالى

كود من شأنه طرح القيم المرحلة من صفحة الصادرالى الصفحة الرئيسية

علما بأن العمود المعنى بالاضافة والخصم هو العمودD  بالصفحة الرئيسية

مزيدا من التوضيح برجاء الاطلاع على المرفق والافادة بإذن الله تعالى

تقبلوا وافر تقديرى واحترامى **** وجزاكم الله خيرا

إضافة وخصم الكميات الواردة والصادرة مع كل إدخال جديد.xlsb.rar

تم تعديل يناير 31, 2016 بواسطه سعيد بيرم

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

أخي الفاضل سعيد بيرم

 

كعادتي لم افهم المطلوب ..يبدو أنني أتسم بالغباء المطلق حيث أنني لا أستطيع فهم الآخرين بسهولة

أخبرتك أن تذكر المطلوب بشيء من التفصيل .. أوراق العمل المطلوب العمل عليها هي ورقة العمل "الوراد" وورقة العمل "الرئيسية"

أين تتم عمليات الإدخال في أي ورقة وفي أي عمود بالضبط ؟ وما هو المطلوب بعد الإدخال ؟ ويحبذ أن تضرب مثال حي بخلية معينة وشكل النتائج المتوقعة

بالنسبة للأكواد في حدث تغيير ورقة العمل لا أحبذها ...أفضل أن تقوم بالإدخال وفي نهاية المطاق تنفذ الكود مرة واحدة فقط

أرجو أن تكون الصورة واضحة ..

وأعتذر لأنني سأترك الموضوع حيث أنه قد حان وقت نومي وربما لن تراني غداً ..ولفترة من الزمن

ولكن أحببت أن أشارك بهذه المشاركة لتقوم بالتوضيح مرة أخرى حتى يسهل العمل على من يريد تقديم المساعدة

 

تقبل تحياتي

 

[أبو سجده]

أخى الحبيب الغالى // ابو البراء

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

بداية بارك الله فيك وجزاكم الله خيرا

بالمرفق المشار اليه كود ترحيل الكميات الواردة بالعمود C  بصفحة الوارد الى العمود C  بالصفحة الرئيسية

وكود ترحيل الكميات الصادرة بالعمود  I  بصفحة الصادر الى العمود E بالصفحة الرئيسية

و كود بحدث الصفحة الرئيسة من شأنه تجمبع القيم المدخلة تلقائيا بالعمود D  بالصفحة الرئيسية

المطلوب بإذن الله تعالى  كود يقوم بتنفيذ عملية الطرح التلقائى من القيم المدخلة بالعمود D  بالصفحة الرئيسية

بس خلاص ***** فى انتظار ردكم الكريم **** نوما هنيئا واحلاما سعيدة ***** جزاكم الله خيرا وبارك فيكم **** تقبل وافر احترامى

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

كل دا ولا يلزمني بشيء ..أكواد أكواد أكواد ..

خليك معايا عشان أنا هنجت وشكلي بنام وأنا بكلمك

بص بص .. بص يمين شمال مش هتلاقيني ولو لاقيتني باللي ف ايدك واضرب في أي حتة وزي ما تيجي

أصلي بردو مش فاهم المطلوب .. سيبك من الشرح اللي مش جايب همه خلينا في شكل النتائج المتوقعة .. يعني إنت بتدخل البيانات فين وفي أي ورقة وفي أي عمود ؟ وايه المتوقع بعد عمليات الإدخال

ولما تريد أن يتم الأمر تلقائي وفي الحال .. لما لا تقوم بإدخال البيانات ثم تنفيذ الكود بضغطة زر مثلاً .. يرجى يرجى ضرب مثال للتوضيح بخلية محددة

واستحملني يا جدو سعيد أصل ابنك دماغه جزمة ومش بيفهم بسهولة .. لازم تفهمه تاني

تقبل تحياتي

 

[أبو سجده]

حبيبى ابو البراء 

ياأخى الغالى العفو ****  بالله عليك لاتشعرنى ما لايقوى عليه جسدى يوم الحشرالاعظم

 والله العظيم انت كتر الف خيرك ***وكفاية أدبك وذوقك لانك ابن حلال ومتربى على الغالى

ببساطة من فضلك اضغط على الزرالموجود بصفحة الوارد لتفيذ كود الترحيل ولاحظ 

العمود D بالصفحة الرئيسية ستلاحظ أنه يزداد 100 كلما ضغطنا على زر الترحيل

بهذة الخطوة تصبح الاضافة المطلوبه

أما عملية الطرح أريد كلما ضغطنا على زر الترحيل الموجود بصفحة الصادر لترحيل العمود I

الى العمود E  بالصفحة الرئيسية يقل هذا المبلغ من القيمة الموجودة بالعمود D بالصفحة الرئيسية

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

رجاء الاطلاع على الرابط التالى فالموضوع فى الاصل موضوعك ***** فى الانتظارغدا بحول الله 

وإن إستطعت فأنا سهران للصباح بإذن الله لانشغالى لاتمام هذا الموضوع معلشى هسجل خروج

لان حاطط يدى على قلبى نظرا لاقتراب نفاذ رصيد USB ***** والله المستعان

مرفق ملف للتوضيح ***** جزاكم الله خيرا وبارك فيكم

خصم وإضافة.xlsb.rar

تم تعديل فبراير 1, 2016 بواسطه سعيد بيرم

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

أخي العزيز سعيد

قم بوضع الكود التالي بعد تعديل بسيط في موديول عادي

Sub TransferMatchingData()
    Dim vItems As Variant, vData As Variant, I As Long
    
    vItems = Sheet1.Range("B8", Sheet1.Cells(Rows.Count, "B").End(xlUp)).Resize(, 2).Value
    
    With Sheet2.Range("B8", Sheet2.Cells(Rows.Count, "B").End(xlUp))
        vData = .Value
        
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For I = LBound(vItems) To UBound(vItems)
                .Item(vItems(I, 1)) = vItems(I, 2)
            Next I
            
            For I = LBound(vData) To UBound(vData)
                If .Exists(vData(I, 1)) Then
                    vData(I, 1) = .Item(vData(I, 1))
                Else
                    vData(I, 1) = ""
                End If
            Next I
        End With
        
        .Offset(, 1).Value = vData
    End With
End Sub


Sub TransferMatchingItems()
    Dim vItems As Variant, vData As Variant, I As Long
    
    vItems = Sheet5.Range("C8", Sheet5.Cells(Rows.Count, "C").End(xlUp)).Resize(, 7).Value
    
    With Sheet2.Range("B8", Sheet2.Cells(Rows.Count, "B").End(xlUp))
        vData = .Value
        
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For I = LBound(vItems) To UBound(vItems)
                .Item(vItems(I, 1)) = vItems(I, 7)
            Next I
            
            For I = LBound(vData) To UBound(vData)
                If .Exists(vData(I, 1)) Then
                    vData(I, 1) = .Item(vData(I, 1))
                Else
                    vData(I, 1) = ""
                End If
            Next I
        End With
        
        .Offset(, 3).Value = vData
    End With
End Sub

 

قم بحذف الكود الموجود في موديول والذي يشير إلى Workbook_Change ويحبذ ألا تستخدم التغير في حدث ورقة العمل بالمصنف

*********************************************************************************************

وأخيراً قم بوضع الكود التالي في حدث ورقة العمل المسماة "الرئيسية"

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.CountLarge > 1 Then Exit Sub
    If Target.Column = 5 And Target.Row > 7 Then
        Application.ScreenUpdating = False
        Application.EnableEvents = False
        
            If Target.Value > Target.Offset(, -1) Or IsEmpty(Target.Offset(, -1)) Then
                MsgBox "الكمية المباعة أكبر من الكمية الموجودة أو لا يوجد كميات موجودة على الإطلاق", vbExclamation
                Target.ClearContents: Target.Activate
            Else
                Target.Offset(, -1).Value = Target.Offset(, -1).Value - Target.Value
                Target.ClearContents
            End If
        
        Application.EnableEvents = True
        Application.ScreenUpdating = True
        
        ElseIf Target.Column = 3 And Target.Row > 7 Then
        Application.ScreenUpdating = False
        Application.EnableEvents = False
        
            Target.Offset(, 1).Value = Target.Offset(, 1).Value + Target.Value
            Target.ClearContents
        
        Application.EnableEvents = True
        Application.ScreenUpdating = True
    End If
End Sub

تقبل تحياتي

 

إضافة وخصم الكميات الواردة والصادرة مع كل إدخال جديد.rar

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

أخي الكريم سعيد

دعك من المشاركة السابقة وإليك الأكواد التالية ..يمكنك الآن الاستغناء عن الأكواد في حدث ورقة العمل لأنني لا أحبذها أصلاً طالما أنه بالإمكان عمل المطلوب دونها

جرب الكودين التاليين أحدهما للإضافة والآخر للخصم

Sub TransferMatchingData()
    Dim vItems As Variant, vData As Variant, vOut As Variant, I As Long
    
    vItems = Sheet1.Range("B8", Sheet1.Cells(Rows.Count, "B").End(xlUp)).Resize(, 2).Value
    
    With Sheet2.Range("B8", Sheet2.Cells(Rows.Count, "B").End(xlUp))
        vData = .Value
        vOut = .Offset(, 1).Resize(, 2).Value
        
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For I = LBound(vItems) To UBound(vItems)
                .Item(vItems(I, 1)) = vItems(I, 2)
            Next I
            
            For I = LBound(vData) To UBound(vData)
                If .Exists(vData(I, 1)) Then
                    vOut(I, 1) = .Item(vData(I, 1))
                    vOut(I, 2) = vOut(I, 2) + vOut(I, 1)
                Else
                     vOut(I, 1) = ""
                End If
            Next I
        End With
        
        .Offset(, 1).Resize(, 2).Value = vOut
    End With
End Sub

Sub TransferMatchingItems()
    Dim vItems As Variant, vData As Variant, vOut As Variant, I As Long
    
    vItems = Sheet5.Range("C8", Sheet5.Cells(Rows.Count, "C").End(xlUp)).Resize(, 7).Value
    
    With Sheet2.Range("B8", Sheet2.Cells(Rows.Count, "B").End(xlUp))
        vData = .Value
        vOut = .Offset(, 2).Resize(, 2).Value
        
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For I = LBound(vItems) To UBound(vItems)
                .Item(vItems(I, 1)) = vItems(I, 7)
            Next I
            
            For I = LBound(vData) To UBound(vData)
                If .Exists(vData(I, 1)) Then
                    vOut(I, 2) = .Item(vData(I, 1))
                    vOut(I, 1) = vOut(I, 1) - vOut(I, 2)
                Else
                    vOut(I, 1) = ""
                End If
            Next I
        End With
        
        .Offset(, 2).Resize(, 2).Value = vOut
    End With
End Sub

تقبل وافر تقديري واحترامي

[أبو سجده]

اخى وحبيب قلبى صاحب القلب الكبير الحنون

ابو البراء 

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

من أي أبواب الثناء سندخل وبأي أبيات القصيد نعبر

وفي كل لمسة من جودكم وأكفكم للمكرمات أسطر

أنتم كسحابة معطاءه سقت الأرض فاخضرت

أتمنى من الله عز وجل أن يعطيكم الصحة والعافية

شكراُ لكم على ما قدمتموه لي من أحاسيس نابعة من قلوبكم

ودام الله عزكم ودام عطائكم

جزاكم الله خيرا وأسعدكم الله فى الدارين 

 

تم تعديل فبراير 1, 2016 بواسطه سعيد بيرم

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

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

بارك الله فيك وجزيت خيراً على كلماتك الرقيقة في حقي

وجزيت خيراً على دعواتك الطيبة المباركة

تقبل وافر تقديري واحترامي