ترحيل + جمع

[فوزى فوزى]

السلام عليكم ورحمة الله وبركاته اساتذتى الكرام بعد عدة محاولات توصلت لعمل هذا الكود وهو يؤدى المطلوب ولكن عندى مشكلة وهى الأسماء المشتركة مع بعضهم عند كتابة محمد وكتابة الشهر يرحل المبلغ امام الاسم الموجود في العمود B ون ضغطت مرة ثانية على الزر الترحيل على نفس الاسم والشهر يقوم بتجيمع المبلغ لحد هنا كله تمام المشكلة تكمن هنا فى الاسماء المشتركة عند كتابة اسم هانى فى الخلية B1 وعند كتابة الشهر فى الخلية B2 لا يرحل المبلغ الموجود فى الخلية B3 المطلوب عند كتابة اسم خالد وكتابة شهر 2 مثلا يرحل المبلغ الى خالد وان كتبت اسم حاتم وكتبت شهر 2 ايضا يرحل المبلغ ويجمعه مع مبلغ خالد وهذا مثال على ذلك

ترحيل + جمع.xlsm

[محمد هشام.]

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

جرب هل هدا ما تقصده

Sub Update_amounts3()
Dim Names$, Amount$, months$, i As Byte
Dim tmp As Range, OneRng As Range, arr As Range
Set f = Sheets("حركة الأقساط")

' الاسم
Names = "*" & [b1].Value & "*"
' الشهر
months = [b2]
'المبلغ
Amount = [b3]

With f
' التحقق من وجود قيمة في خلايا (الاسم-الشهر-المبلغ)
    Set arr = Union(.[b1], .[b2], .[b3])
    For i = 1 To arr.Count
        If arr(i) = Empty Then MsgBox ("يرجى إضافة" & _
        " " & arr(i).Offset(, -1).Value), 16, "إنتباه": Exit Sub
    Next
    ' تنفيد الكود عند التحقق من وجود قيمة رقمية في خلية المبلغ
    If Not IsNumeric(Amount) Then: Exit Sub
        'نطاق البحث عن الاسم
    Set OneRng = .Range("b7", .Range("b" & .Rows.Count).End(xlUp)).Find(Names)
        'نطاق البحث عن الشهر
        Set tmp = [C6:N6].Find(months)
            
 ' صف وجود الاسم
   A = OneRng.Row
 ' عمود وجود الشهر
   B = tmp.Column
 ' الخلية الهدف
  Set c = Cells(A, B)
 'قيمة الخلية الهدف + قيمة المبلغ
     c.Value = c.Value + Amount
       
  End With
End Sub

 

ترحيل + جمع V2.xlsm

تم تعديل أغسطس 13 بواسطه محمد هشام.

[فوزى فوزى]

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

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

هذا الكود المطلوب عليه الاضافة

Sub Trhel()
lr = Range("b" & Rows.Count).End(xlUp).Row
 r = Range("b7:b" & lr).Find([b1], , , 1).Row
 c = Rows(6).Find([b2], , , 1).Column
Cells(r, c) = Val(Cells(r, c)) + Val([b3])

End Sub

لانه كود سهل  وبسيط واستطيع اعدل عليه بعد ذلك وجزاكم الله خير الجزاء

[محمد هشام.]

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

تفضل اخي

Sub Trhel()
 lr = Range("b" & Rows.Count).End(xlUp).Row
 r = Range("b7:b" & lr).Find("*" & [b1].Value & "*", , , 1).Row
 c = Rows(6).Find([b2], , , 1).Column
 Cells(r, c) = Val(Cells(r, c)) + Val([b3])
End Sub

 

تم تعديل أغسطس 13 بواسطه محمد هشام.

[فوزى فوزى]

شاكر فضلك جدا جدا واسال الله ان يجعلكم دئما أهلا لعمل الخير والمساعدة تسلم ايديك وبارك الله فيكم وجعله فى ميزان حسناتك وزادك الله من علمه وفضله 

نعم هذا هو المطلوب