تجميع القيم مع كل إدخال جديد في نفس الخلية Accumulator

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

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

إخواني الكرام ..أحبابي في الله

أقدم لكم اليوم كودين ، تعتمد الفكرة فيهما على تجميع القيم التي يتم إدخالها ، مع كل إدخال جديد

في المرفق ستجد ملفين ..

الملف الأول باسم Single Cell Accumulator أي التجميع للقيم في خلية واحدة فقط ويظهر الناتج في نفس الخلية ..

قم بإدخال أي قيمة في الخلية A1 وليكن 5 ثم سهم لأسفل واكتب القيمة 4 ستجد أن ناتج الخلية أصبح 9 ، اكتب 3 ثم سهم لأسفل ستجد الناتج أصبح 12 وهكذا .. أعتقد أن فكرة الكود قد وصلتكم الآن ..

لإعادة ضبط عملية التجميع قم بمسح محتويات الخلية A1 أو وضع نص بها ..

الكود في الملف الأول بهذا الشكل (في حدث ورقة العمل)

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
      Static dAccumulator As Double
      With Target
         If .Address(False, False) = "A1" Then
            If Not IsEmpty(.Value) And IsNumeric(.Value) Then
               dAccumulator = dAccumulator + .Value
            Else
               dAccumulator = 0
            End If
            Application.EnableEvents = False
            .Value = dAccumulator
            .Select
            Application.EnableEvents = True
         End If
      End With
End Sub

الملف الثاني باسم Two Cell Accumulator وفي هذا الملف تتم عملية الإدخال في الخلية A1 بينما تظهر النتائج في الخلية B1 ، ففي كل إدخال رقمي يتم تجميع القيمة إلى القيمة الموجودة في الخلية A1 ، وهنا إذا تم مسح محتويات الخلية A1 أو كتابة نص بها ، فإن الناتج في الخلية B1 يظل كما هو ، ولإعادة ضبط عملية التجميع من جديد قم بمسح محتويات الخلية B1

والكود في الملف الثاني يظهر بهذا الشكل (في حدث ورقة العمل)

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
      With Target
         If .Address(False, False) = "A1" Then
            If IsNumeric(.Value) Then
               Application.EnableEvents = False
               Range("B1").Value = Range("B1").Value + .Value
               Application.EnableEvents = True
               .Select
            End If
         End If
      End With
End Sub

أرجو من الله أن يجعل أعمالنا صالحة ، ولوجهه خالصة ..

دمتم في رعاية الله

حمل الملف من هنا

[مختار حسين محمود]

بإذن الله تعالى صالحة ، ولوجهه خالصة ..

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

مشكور على مرورك العطر يا مخ (طار)

لكم يسعدني عودتك للمنتدى بعد طووووول غياب ..

في انتظار إبداعاتك المفيدة والجديدة

[Yasser Fathi Albanna]

جزاك الله خير يا أغلى إسم

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

وجزيت خيرا يا با شمهندس ..ومشكور على تشجيعك الدائم لي

[عبدالله فاروق ابو ريان]

أستاذنا الفاضل ياسر
جزاك الله خيراً تعودنا منكم دائماً على كل ماهو جديد

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

وجزيت خير الجزاء يا أخي عبد الله على مرورك العطر

تقبل تحياتي

[KHMB]

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

اخي الفاضل ابو البراء

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

أي مثل شريط الآله الحاسبة لكي يتم المراجعة لو فيه خطأ.

مثلا / نبدأ من A2 إلى A100 او إلى ان ننتهي أي كامل العمود وتكون ظاهره والمجموع اما في A1 او B1 ويفضل A1

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

أخي الفاضل أبا الحسن والحسين

جرب الكود التالي

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
    If Target.Cells.CountLarge > 1 Then Exit Sub
    If Not Intersect(Target, Range("A2:A100")) Is Nothing Then
        If IsNumeric(Target.Value) Then Range("A1").Value = Target.Value + Range("A1").Value
    End If
End Sub

[KHMB]

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

نعم اخي الفاضل ياسرعمل 100% تسلم

بارك الله فيك وجزاك الله خير الجزاء

[محمد الورفلي1]

السلام عليكم

 

اكواد جميلة وافكار اجمل

 

يارك الله في  عملك

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

والأجمل مرورك العطر أخي محمد الخازمي .

وفي انتظار إبداعاتكم (مش كله هات هات ..الدنيا خد وهات )

[محمد الورفلي1]

والأجمل مرورك العطر أخي محمد الخازمي .

وفي انتظار إبداعاتكم (مش كله هات هات ..الدنيا خد وهات )

 

 

الله الموفق

[لطفى سالم]

اخى واسناذى الفاضل

لقد استفدت كثيرا من علمك الغزير جعلك الله منهلا لنا وانار صدرك بالعلم

اخوك   لطفى سالم

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

الأخ الكريم لطفي سالم

أهلا ومرحباً بك في المنتدى ونورت بين إخوانك

يشرفني أن يكون أول مشاركة لك بالمنتدى موجهه لشخصي ..

وإن شاء الله ننتظر منك مساهمات في القريب العاجل سواء بإفادة أو باستسفار .. ننتظر مشاركاتك القيمة بإذن الله

تقبل تحياتي

[ربيع الأول]

أخي الكريم أبو البراء وإخوتي الكرام أعضاء المنتدى

رمضان مبارك علينا وعليكم جميعا

أود أن أسطر في أول زيارة لي إعجابي بهذا المنتدى الكبير وما يحتويه من موضوعات مفيدة وقيمة، فقد استفدت منه كثيرا كشخص مبتدئ في الاكسل، جزى الله القائمين عليه والمشاركين فيه خير الجزاء..

الكود الثاني الذي تفضل به الأستاذ ياسر كنت أبحث عنه منذ مدة حتى هداني البحث إلى هذه الصفحة الرائعة، لكن لدي طلبان إن تكرمتم على أخيكم:

الأول: الخلية الأولى (خلية الإدخال) في الملف الذي أعمل عليه هي عبارة عن معادلة، أي أن الإدخال فيها تلقائي، وقد لاحظت أن الكود لا يستجيب إلا إذا كان إدخال القيمة يدويا، فهل هناك حل لهذه المسألة؟

الثاني: أريد تطبيق الكود على خلايا كثيرة، فهل يلزمني إعادته في كل مرة؟ 

جزاكم الله عن أخيكم خير الجزاء

 

[ابو عبدالرحمن البغدادي]

جزيت خيرا

 

[ربيع الأول]

هل من مساعدة في الحل أيها الأحباب؟

[ربيع الأول]

لله يا محسنين.

[ربيع الأول]

عشمي بكم كبير يا أحباب، فلا تخيبوني

 

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

أخي الكريم ربيع الأول

أعتذر عن التأخر في الرد عليك فإنني في شغل في هذه الفترة وسأغيب لفترة طويلة بعض الشيء

أفضل طرح موضوع جديد لطبك مع إرفاق ملف معبر عن الملف الأصلي ، وإن شاء الله ستجد من يقدم لك يد العون

كل عام وأنت بخير

[ربيع الأول]

شكرا لك ولجمالك أستاذي الكريم وكل عام وأنت والأعضاء الكرام بألف خير

سأطرح الموضوع من جديد.

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

تم تحديث الملف في المشاركة الأولى حيث أن الرابط القديم وجدته مفقود .. 

تقبلوا تحياتي

[حسين مامون]

السلام عليكم 

استاذنا حفظك الله

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

تحياتي

[mohamed concor]

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