كود جمع واختصار بيانات

[محمد عبد الناصر]

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

اريد ان ينتقل البيانات في الشيت الخاص المسمى بتقرير الدكاتره

الملف المرفق موضح المطلوب

شكرا لكم

5.xlsx

[amrhosny]

اخي الكريم لك ما طلبت

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

5-1.xlsx

[محمد عبد الناصر]

سلمت اخي الكريم ولكن هناك امر واحد فقط 

انا اتعامل مع كثير من المرضى لا اريد كتابة اسم المريض فاذا هناك كود يكتب اسم المريض دون تكرار فسوف يفي بالغرض

 

[amrhosny]

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

وفي شيت التقرير اختار الاسم من القائمة المنسدلة

واذا تم التكرار سيتغير اللون وينبهك انه هناك تكرار

5.xlsx

[محمد عبد الناصر]

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

[amrhosny]

اخي الفاضل تم عمل المطلوب كما تريد

تم عمل ترقيم تلقائي

تم الغاء الاصفار اذا كانت القيم تحتوي على 0

5-5.xlsx

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

جرب هذا الملف

يحتوي على 3 أكواد ( الكود الأول  لتعريف المتغيرات      الكود الثاني يقوم باضافة اسماء المرضى     الثّالث للفواتير)

الأكواد الثلاثة تعمل معاَ بالضغط على الزر "Give Data"

Option Explicit
Global D As Worksheet
Global LrR%, m%, i%
Global R As Worksheet

'+++++++++++++++++++++++++
Sub Debut()
 ' Code #1
Set D = Sheets("Dr_Repport")
Set R = Sheets("Repport")
LrR = R.Cells(Rows.Count, 2).End(3).Row
End Sub
'++++++++++++++++++++
Sub Uniqe_Malade()
Debut
' Code #2
If LrR < 5 Then Exit Sub
D.Range("A8:b8").Resize(1000).ClearContents
m = 8
For i = 5 To LrR
 If Application.CountIf(R.Range("B5:B" & i), R.Range("B" & i)) = 1 Then
    D.Cells(m, 2) = R.Range("B" & i)
    D.Cells(m, 1) = m - 7
    m = m + 1
    End If
 Next
End Sub
'+++++++++++++++++++
  Sub Doctors_Facture()
' Code #3
         Rem Created by Salim Hasbaya On 23/10/2020
Uniqe_Malade
Dim k%, RoR%, RoD%, x%, t%
Dim all#, y%
Dim arr(1 To 4)

RoR = R.Cells(Rows.Count, 2).End(3).Row
If RoR < 5 Then Exit Sub

RoD = D.Cells(Rows.Count, 2).End(3).Row
If RoD < 8 Then Exit Sub

arr(1) = "دكتور حاتم": arr(2) = "دكتور احمد"
arr(3) = "دكتورة رانيا": arr(4) = "دكتور محمد"

D.Range("C8:N1000").ClearContents
For k = 1 To 4
y = 8
    For t = 8 To RoD
          For x = 5 To RoR
          If R.Cells(x, "i") = arr(k) _
            And R.Cells(x, "B") = D.Cells(t, 2) Then
            all = all + IIf(IsNumeric(R.Cells(x, "H")), _
            R.Cells(x, "H"), 0)
          End If
          Next x
        With D.Cells(y, 3 * k)
         .Value = all
         .Offset(, 1) = Round(all * 0.4, 2)
         .Offset(, 2) = Round(all * 0.6, 2)
        End With
        all = 0: y = y + 1
    Next t
Next k

End Sub

الملف مرفق

Adb_naser.xlsm

[محمد عبد الناصر]

استاذي الفاضل احمد يوسف متى انا قمت بنسيان حق الاساتذه الافاضل ؟ بالعكس انا دائما ما ادعو لهم هنا وفي عملي فهم لهم الفضل علي وهم السبب في كوني مستمر في عملي 
فاذا انشغلت عن الرد او المتابعه لنصف ساعه فهذه اساءه ؟ 
اعتذر منك اخي الكريم انا احترم كل من يساعدني هنا وانا لم اقم باي شيء قولته لي 

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