جمع العناصر المتشابهة باستخدام المصفوفات

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

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

وبه نستعين

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

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

الكود المبين أمام حضراتكم بالمرفق التالى

لترحيل القيم المدونة  بالعمود  I    من الورقة  Data  الى الورقة salary  قرين كل إسم

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

معالجة الكود المشار اليه ليتم تجميع قيم العناصر المتشابهة وترحليها من الورقة  Data  الى الورقة  Salary

مثالا على ذلك

بالورقة data  رقمى  5 و 66 يحملا نفس الاسم مع إختلاف القيم المدونة بالعمود I

النتيجة المطلوبة بإذن الله بعد معالجة الكود = 1626.04

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

 

جمع العناصر المتشابهة باستخدام المصفوفات.rar

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

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

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

Sub sum_if()
my_max = Application.Max(Sheets("Salary").Range("a:a"))
Sheets("Salary").Range("c8:c" & my_max).Formula = "=IF(B8<>"""",SUMIF(Data!$B$7:$B$200,$B8,Data!$I$7:$I$200),"""")"
Sheets("Salary").Range("c8:c" & my_max).Value = Sheets("Salary").Range("c8:c" & my_max).Value
End Sub

 

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

الاستاذ الفاضل // سليم

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

أطمع فى معالجة الكود برمجيا 

وافر تقديرى واحترامى

 

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

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

للرفع

[أبو حنــــين]

السلام عليكم

أخي أبو عبد الرحمان جرب المرفق

تم إلغاء دمج الخلايا في صفحة Salary الصف السابع

جمع العناصر المتشابهة باستخدام المصفوفات.rar

تم تعديل يوليو 28, 2016 بواسطه أبو حنــــين

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

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

أخى وحبيبى فى الله أبو حنين

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

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

فى موازيين حسناتكم وأن يجعل أيامك كلها سعادة وهناء

اللهم أمين **** اللهم أمين **** اللهم أمين

أخى ابو حنين

كخطوة أولى بسم الله ماشاء الله ***** لقد قرأت ما فى ذهنى ببراعة شديدة

ولكن للأسف الشديد وبطريق الخطأ تم رفع المرفق على غير المطلوب ولم يسعفنى الوقت لتعديل المشاركة

ولم أكتشف هذا الخطأ إلا بعد تحميل المرفق المرسل من طرفكم

وإستكمالا لما تفضلت به من جهد كبير تؤجر عليه من رب العباد

جارى العمل على  مراجعة  المرفق الصحيح قبل رفعه

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

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

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

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

أخى وحبيبى فى الله أبو حنين

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

برجاء التفضل بالإطلاع على المرفق التالى

حيث تم تصويب المرفق نحو المطلوب

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

جمع العناصر المتشابهة باستخدام المصفوفات +1111.rar

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

للرفع

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

للرفع

[أبو حنــــين]

السلام عليكم

اعتذر اخي ابو عبد الرحمان للتأخر عن الرد بسبب النت 

جرب المرفق و تأكد من النتائج و اخبرني 

جمع العناصر المتشابهة 1.rar

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

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

والله ياأبو حنين أنا اللى بعتذر ومقدر جدا جدا 

مدى إخلاصكم ومدى محبتك الخالصة لله تعالى

ومدى مجهوداتك نحو تقديم ماأنعم الله به عليك

جارى تجربة المرفق وسأخبرك بالنتيجة فور الانتهاء 

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

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

أخى العزيز المحترم // أبو حنين

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

برجاء التفضل بالإطلاع على المرفق التالى

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

 

جمع العناصر المتشابهة 22.rar

[أبو حنــــين]

مرحبا

على ما يبدو ان القيمة 2000  هي حاصل جمع القيم : ( 800 + 100 ) + ( 500 + 600 )

و إن كان الأمر كذلك فمعنى هذا أنه لا ينبغي مسح القيم السابقة (كل ما تتغير القيمة لشخص تضاف لسابقتها )

و ان كان الأمر يختلف عن هذا فأرجو التوضيح عن مصدر الرقم 2000

 

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

أخى العزيز المحترم / ابو حنين

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

نعم أخى الحبيب كما أشرت ان القيمة 2000 حاصل جمع ( 800 + 100 ) + ( 500 + 600 )

بشأن الكود TransferMatchingItemsUsingArrays المشار اليه بالموديول رقم 2

ماهو إلا مثالا لتنفيذ الفكرة العامة للموضوع

حيث يتم الاضافة بالعمود Z بمقدار القيمة  المدونة بالعمود  AA بالورقة Salary

كلما تم تنفيذ الكود ومع تغير القيمة المدونة بالعمود I بالورقة Data 

يتم ترحيل القيمة الجديدة وجمعها على القيمة المدونة بالعمود  Z بالورقة Salary

مثالا على ذلك

لديك بالرقم المسلسل " أبو حنين 9 " مبلغ 100 ج  برجاء التفضل تنفيذ الكود ثلاث مرات يصبح النتاتج لديك 300 ج

مع تغير المبلغ بذات الصف الى 1425.80 ستلاحظ أخى الحبيب أن مبلغ ال 100 ج ليس له محلا من  الوجود

وقد حل محله مبلغ ال 1425.80 وبالتالى تصبح جملة المبلغ  1725.80  

أعتذر للإطالة **** تقيل وافر تقديرى واحترامى **** وجزاكم الله خيرا

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

للرفع

[أبو حنــــين]

السلام عليكم

اخي ابو عبد الرحمان

أخوك ابو حنين بطيئ الفهم 

أرفقت لك ملف أريد فيه بعض التوضيح

 

مثال.rar

تم تعديل أغسطس 3, 2016 بواسطه أبو حنــــين

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

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

أخى ابو حنين

ياحبيبى العفو *** العفو

اسعدك الله فى الدارين وبارك فيكم

إليك أخى هذا المرفق فيه التوضيح المطلوب

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

مثال + 1.rar

[أبو حنــــين]

السلام عليكم

اعتقد و الله اعلم أنه تم عمل المطلوب

 

جمع العناصر المتشابهة 33.rar

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

أخى الحبيب الغالى // ابو حنين

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

بإذن الله تعالى سيكون المطلوب

تم تحميل المرفق ولنا عودة بحول الله تعالى

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

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

أخى الحبيب الغالى // ابو حنين

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

بارك الله فيك ورزقكم الله وإيانا من حيث لا تحتسب

تم بحمد الله وبفضله ثم بفضلك أخى الحبيب

وشاكرا جدا جدا حسن صنعيك وعلى إهتمامكم البالغ

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

[omar elhosseini]

 

الاخ ابو عبدالرحمن بيرم

اسف اخي علي التأخير

فلم اري رسالتك الا اليوم

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

Omar_1.rar

 

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

الاستاذ الفاضل // عمر الحسينى

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

والله يا أخى أنه لشرف كبير مروركم الطيب المبارك

واعتذر لعدم الرد فى حينه 

واليك الكود الذى  أتعبنا كثيرا على مدار عدة ايام

بجد رغم سعادتى بتنوع الحلول خاصة مابذله معى أخى  الحبيب ابو حنين  من جهد كبير

فجزاه الله تعالى عنى خير الجزاء  وجزاكم  الله خيرا

  إلا أننى حزين لان ماتم عليه من تعديل تعديلا طفيفا لايذكر ولكنها مشيئة الله

أسعد دائما بلقائكم جميعا **** تقبلوا وافر تقديرى واحترامى

Option Explicit
Sub TransferMatchingItemsUsingArrays()
    Dim vItems As Variant, vData As Variant, vOut As Variant, i As Long
    vItems = Sheet2.Range("B8", Sheet2.Cells(Rows.Count, "B").End(xlUp)).Resize(, 8).Value
    With Sheet1.Range("B8", Sheet1.Cells(Rows.Count, "B").End(xlUp))
        vData = .Value
        vOut = .Offset(, 22).Resize(, 2).Value
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For i = LBound(vItems) To UBound(vItems)
               ' .Item(vItems(i, 1)) = vItems(i, 8)
                .Item(vItems(i, 1)) = .Item(vItems(i, 1)) + vItems(i, 8)
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, 2) = ""
                End If
            Next i
        End With
        .Offset(, 22).Resize(, 2).Value = vOut
    End With
End Sub

 

[omar elhosseini]

 

هل يعمل يعمل هذا الكود

اذا كان يعمل اود ان اراي الملف الذي يعمل عليه

 

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

نعم أخى عمر

جميع الملفات الواردة تعمل بشكل أكثر من ممتاز

ولكن مايميز المرفق المطلوب أن قائمة الاسماء المراد الترحيل اليها قائمة ثابته

حيث  تحتوى على قرابة الـــ 38000 موظف وتم إجتياز هذة الجزئية 

بالمرفقين المرسلين من أخى الحبيب ابو حنين ومن سيادتكم

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

[omar elhosseini]

5 hours ago, عمر الحسيني said:

 

هل يعمل يعمل هذا الكود

اذا كان يعمل اود ان اراي الملف الذي يعمل عليه

 

الاخ ابو عبدالرحمن بيرم

لم تجيبني علي طلبي بأن ترسل الملف الذي به الكود السابق والذي يعمل بشكل جيد

فأنا اري ان به شئ غير منضبط