طلب ترحيل بشروط واضافه الى السابق ترحيله

[الصقر الحر]

الساده اساتذة وخبراء اكسيل

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

لى طلب بخصوص الترحيل - لدى ملف اكسيل به صفحتان الأولى خاصه بالمكافآت اللتى يحصل عليها الموظف وأخرى لتجميع المكافآت على مدار السنه .
المطلوب : عند عمل مكافآة لموضف ما فى مثلا يناير يتم ترحيلها أمام الموظف فى صفحة التجميع وتحت نفس الشهر لو أعطى مثلا مكافة آخرى أو أكثر فى نفس االشهر يتم اضافتها الى ماسبق واذا اعطى له مكافآ مثلا فى شهر فبراير يتم ترحيلها لنفس عمود الشهر وهاكذ

ولسيادتكم جزيل الشكر والعرفان

ex1.rar

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

جرب المرفق

 

 

ex1 salim.rar

[الصقر الحر]

الأستاذ الفاضل / سليم  اشكرك على  مرورك العطر

ارغب فى الترحيل من  ورقه المكافآة الى ورقه التجميع مع مراعاة  فى ورقه المكافآه اذا تم عمل  مكافآه أخرى عن نفس الشهر يتم تجميع على المكافآت الاخرى بورقه التجميع

 

تم تعديل مارس 13, 2017 بواسطه الصقر الحر

[الصقر الحر]

6 ساعات مضت, سليم حاصبيا said:

جرب المرفق

 

 

ex1 salim.rar

اشكرك الأستاذ / سليم .. ليس هو المطلوب ارغب فى الترحيل من ورقه المكافآة الى ورقه التجميع  مع الأضافه الى ماسبق ترحيله لنفس الشهر

تم تعديل مارس 13, 2017 بواسطه الصقر الحر

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

في هذه الحالة اليك هذا الماكرو

Sub transfer_with_ٍSalim()

Dim Sht_Source, Sht_Target As Worksheet
Dim lr1, lr2, My_Row, My_Column As Integer
Dim My_Name As String, Oldsum

Set Sht_Source = Sheets("المكافآة"): Set Sht_Target = Sheets("تجميع المكافآت على مدار العام")
 lr1 = Sht_Source.Cells(Rows.Count, 1).End(3).Row
 lr2 = Sht_Target.Cells(Rows.Count, 1).End(3).Row
 My_Column = Application.Match(Sht_Source.Range("d2"), Sht_Target.Range("c4:n4"), 0) + 2
   
  For i = 5 To lr1
         My_Name = Sht_Source.Range("b" & i).Value
         My_Row = Application.Match(My_Name, Sht_Target.Range("b5:b" & lr2), 0) + 4
        Oldsum = Sht_Target.Cells(My_Row, My_Column)
         If IsNumeric(Sht_Source.Cells(i, 3)) And IsNumeric(Oldsum) _
        Then Sht_Target.Cells(My_Row, My_Column) = Oldsum + Sht_Source.Cells(i, 3)
   Next
End Sub

 

[الصقر الحر]

اشكرك جزييلا الأستاذ العظيم / سليم

سلمت يا أخى من كل شر وبارك الله فى صحتك وعلمك .. الكود اكثر من رائع ويعمل بكفاء

اشكرك

[الصقر الحر]

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

كيف يتم التعديل لو كانت الأسماء ليست بنفس الترتيب مثل الملف المرفق كيف يتم التعديل على الكود  بحيث يتم ترحيل المبلغ بالأضافه الى المبلغ السابق قرين الأسم له فى فى شيت تجميع بيانات المكافآه

مرفق الملف به الكود الخاص بحضرتك

 

 

ترحيل مع تجميع.rar

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

4 ساعات مضت, الصقر الحر said:

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

كيف يتم التعديل لو كانت الأسماء ليست بنفس الترتيب مثل الملف المرفق كيف يتم التعديل على الكود  بحيث يتم ترحيل المبلغ بالأضافه الى المبلغ السابق قرين الأسم له فى فى شيت تجميع بيانات المكافآه

مرفق الملف به الكود الخاص بحضرتك

 

 

ترحيل مع تجميع.rar

لتجاوز الاحطاء تم تعديل الكود

Sub transfer_with_ٍSalim1()

Dim Sht_Source, Sht_Target As Worksheet
Dim lr1, lr2, My_Row, My_Column As Integer
Dim My_Name As String, Oldsum
Dim My_Error As Long

Set Sht_Source = Sheets("المكافآة"): Set Sht_Target = Sheets("تجميع المكافآت على مدار العام")
 lr1 = Sht_Source.Cells(Rows.Count, 1).End(3).Row
 lr2 = Sht_Target.Cells(Rows.Count, 1).End(3).Row
 My_Column = Application.Match(Sht_Source.Range("d2"), Sht_Target.Range("c4:n4"), 0) + 2
   
  For i = 5 To lr1
   On Error Resume Next
 
         My_Name = Sht_Source.Range("b" & i).Value
         My_Row = Application.Match(My_Name, Sht_Target.Range("b5:b" & lr2), 0) + 4
         '==============================================
       My_Error = Err.Number: If My_Error <> 0 Or My_Name = "" Then GoTo 1
       Oldsum = Sht_Target.Cells(My_Row, My_Column)
       Sht_Target.Cells(My_Row, My_Column) = Oldsum + Sht_Source.Cells(i, 3)
           '==============================================
1:        My_Error = 0
   Next
End Sub

 

[الصقر الحر]

الأخ الفاضل / سليم

كم انت اكثر من رائع .. ربنا يزيك ويعطيك من فضله

الكود اكثر من رائع وجميل ويعمل بكفاءة

أشكرك من كل قلبى

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

اشكرك مره آخرى على سرعه استجابتك وزوقك واهتمامك

تم تعديل مارس 16, 2017 بواسطه الصقر الحر