توزيع المبالغ

[فوزى فوزى]

السلام عليكم ورحمة الله وبركاته ارجو المساعدة فى هذا الشيت لتوزيع المبالغ هناخذ مثال محمود اسمه مكرر مرتين مرة لوحدة ومرة أخرى اسمه مشترك مع اسم محمد ،، و محمود هيدفع 150 هنا يبدء ينظر في الخلية E1 مكتوب فيها كام 100 هنا هيسدد لمحمود 100 هيتفضل 50 هتروح فين 50 هتروح في الاسم المشترك مع محمد يبقى كد محمود فلوسة التوزعت 100 في خلية لوحدة و50 فى خلية الاخرى ـ محمد مبلغة 50 هيدفع 50 وفى الخلية دى كان فيها 50 بتاعت محمود هنا يبدء يجمع 50 محمود + 50 محمد يكون الناتج 100 ، المثال الاخر سعيد داخل باربع ادوار وبيدفع 400 هينظر فى الخلية E1 مكتوب فيها كام 100 من هنا يبدء يرحل 100 امام كل اسم سعيد  ويكون الترحيل بشرط الاسم وشرط شهر ويكون الترحيل فى شيت تجميع المبالغ  والله الموفق

الجمعية الشهرية (2).xlsm

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

عليكم السلام

ممكن؟؟!!!

Sub test()
Dim ws As Worksheet: Set ws = Sheets("توزيع المبالغ")
Dim sh As Worksheet: Set sh = Sheets("تجميع المبالغ")
Dim a, b, c, m, d
Dim i&, ii&, x&
a = ws.Cells(6, 7).CurrentRegion
b = sh.Cells(6, 1).CurrentRegion.Offset(2).Columns(1)
ReDim c(1 To UBound(b) - 2, 1 To 2)
m = ws.Range("E1")
    For i = 2 To UBound(a)
        For ii = 6 To UBound(a, 2)
            If (a(i, ii)) = "" Then Exit For
            x = Application.Match(a(i, ii), b, 0)
            c(x, 1) = IIf(c(x, 1) = "", a(i, 2), c(x, 1) & " + " & a(i, 2))
         If a(i, 4) <= m Then
         c(x, 2) = c(x, 2) + a(i, 4)
         Else
         c(x, 2) = c(x, 2) + m: a(i, 4) = a(i, 4) - m
         End If
        Next
    Next
    d = sh.Range(sh.Cells(5, 1), sh.Cells(5, 1).End(xlToRight)).Value
    On Error Resume Next
    For i = 1 To UBound(d, 2): d(1, i) = Split(d(1, i), "/")(0): Next
    d = Application.Transpose(d)
    x = Application.Match(Split(ws.Range("E7"), "/")(0), d, 0)
    With sh
   .Cells(6, 2).Resize(UBound(c)) = c
    .Cells(6, x).Resize(UBound(c)) = Application.Index(c, 0, 2)
    End With
End Sub

 

الجمعية الشهرية (2) (3).xlsm

تم تعديل ديسمبر 6, 2022 بواسطه محي الدين ابو البشر

[فوزى فوزى]

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

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

المشكلة لا أدري اين إدخال الشهر (في أي خلية)!!!!

أنا افترضت التغيير في الخلية E1!!!!?

تم تعديل ديسمبر 6, 2022 بواسطه محي الدين ابو البشر

[فوزى فوزى]

شكرا على الاستجابة استاذنا الفاضل   

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

 

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

تفضل

الجمعية الشهرية (2) (3).xlsm

[فوزى فوزى]

ادخلت التواريخ فى الرنج E13:E7 ومازالت تلك المشكلة موجوده يرحل الى شهر 12 فقط ومها اخترت اي شهر اخر  لا يرحل الا لشهر 12

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

غريب فعلا غريب

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

ربما نسخ الاكسل عندك!!

انا أعمل على نسخة 2019

الجمعية الشهرية (2) (3).xlsm

[فوزى فوزى]

والله مازال نفس الاشكال لايرحل الا لشهر 12 فقط ولا يرحل الى الشهور الاخرى

[حسونة حسين]

اخى @فوزى فوزى

ارفق ملف بعد ان تعمل التغييرات التي تريدها في الشيت

وشكل النتائج المطلوبه 

اشرح في الشيت الخطأ والصواب مفروض يكون ايه 

[فوزى فوزى]

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

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

أخي العزيز

ممكن تستبدل بهذا الكود عسى ولعل

Sub test()
Dim ws As Worksheet: Set ws = Sheets("توزيع المبالغ")
Dim sh As Worksheet: Set sh = Sheets("تجميع المبالغ")
Dim a, b, c, m, d
Dim x#
Dim i&, ii&
a = ws.Cells(6, 7).CurrentRegion
b = sh.Cells(6, 1).CurrentRegion.Offset(2).Columns(1)
ReDim c(1 To UBound(b) - 2, 1 To 2)
m = ws.Range("E1")
    For i = 2 To UBound(a)
        For ii = 6 To UBound(a, 2)
            If (a(i, ii)) = "" Then Exit For
            x = Application.Match(a(i, ii), b, 0)
            c(x, 1) = IIf(c(x, 1) = "", a(i, 2), c(x, 1) & " + " & a(i, 2))
         If a(i, 4) <= m Then
         c(x, 2) = c(x, 2) + a(i, 4)
         Else
         c(x, 2) = c(x, 2) + m: a(i, 4) = a(i, 4) - m
         End If
        Next
    Next
    d = sh.Range(sh.Cells(5, 4), sh.Cells(5, 4).End(xlToRight)).Value
    On Error Resume Next
    For i = 1 To UBound(d, 2): d(1, i) = 1 * Split(d(1, i), "/")(0): Next
    d = Application.Transpose(d)
    x = Application.Match(1 * Split(ws.Range("E7"), "/")(0), d, 0)
    With sh
    .Cells(6, 2).Resize(UBound(c)) = c
    .Cells(6, x + 3).Resize(UBound(c)) = Application.Index(c, 0, 2)
    End With
End Sub

 

[فوزى فوزى]

اولا الف شكر على تعبك ومجهودك ربنا يجعله فى ميزان حسناتك ولكن  والله مازال نفس المشكل لا يرحل الا لشهر 12 فقط مهما غيرت فى التواريخ هو يرحل لشهر 12

[حسونة حسين]

بعد اذن الاستاذ @محي الدين ابو البشر

اخى @فوزى فوزى

عدل السطر

For i = 1 To UBound(d, 2): d(1, i) = 1 * Split(d(1, i), "/")(0): Next
الى
For i = 1 To UBound(d, 2): d(1, i) = 1 * Split(d(1, i), "/")(1): Next

وايضا السطر

x = Application.Match(1 * Split(ws.Range("E7"), "/")(0), d, 0)
الى
x = Application.Match(1 * Split(ws.Range("E7"), "/")(1), d, 0)

عسي ان يكون طلبك ان شاء الله

[فوزى فوزى]

اتوجه بالشكر والعرفان الى الاستاذ محى الدين على تعبه معى فى هذا الشيت وصبر كثير معى الف شكر فانتم اهل عطاء وهذا ليس بغريب عليكم والف شكر الى الاستاذ حسونة على التعديلات التى ادخلها الى الكود حتى اصبح يعمل بشكل جميل وممتاز الف الف شكر

[حسونة حسين]

الشكر لله اخى والحمد لله الذي بنعمته تتم الصالحات 

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

الحمد لله 

وكل الشكر