حساب لكل من الذكر والانثي و الغير محدد بالاكواد

[fantap]

السلام عليكم  مرفق  لحاضرتكم  ملق اكسيل مكون عدد من اوراق العمل
اريد  كود vba  لمعرفه اعداد الذكور  و اعداد الاناث و اعداد الغير محدد  طبقا  للرقم  القومي   حيث يعتمد  علي  الشيت الاساسي Sheet_Main 
العمود  I في  الجدول  الاول  و هو  النوع تم  استخراجه بواسطه  معادله بناء  علي الرقم  القومي و العمود S  يحتوي علي نوع العميل  للعملاء  للمصروفه
مع العلم  ان  لو العميل  اجنبي   فبالتالي  لم استطع  الحصول علي نوعه  ذكر  ام انثي  و كذلك لم استطع  الحصول علي  سنه   لذا  تم كتابتها  غير محدد 
علما  بان  اسماء العملاء ليست  فريده    اي انها ممكن ان يكون فيها  تكرارات
اريد كود  VBA لحساب   عدد الذكور  عدد الاناث   عدد  الغير محدد و اجمالي  المبالغ لكل فئه  و عدد العمليات  التي نفذها كل فئه
شكرا جزيلا  للمساعد و مرفق عينه  بسيطه  من العملاء
كلمة  المرور  vbaproject:0404701219

النسخه النهائيه+++++++++++.xlsm

تم تعديل يوليو 28 بواسطه fantap

[hegazee]

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

جرب الكود التالي

Sub CalculateGenderStats()

    Dim wsMain As Worksheet
    Dim wsGender As Worksheet
    Set wsMain = ThisWorkbook.Sheets("Sheet_Main")
    Set wsGender = ThisWorkbook.Sheets("Gender Male Female")

    Dim LastRowMain As Long
    LastRowMain = wsMain.Cells(wsMain.Rows.count, "A").End(xlUp).Row

    ' متغيرات للحوالات المصدرة (من العمود I - نوع الراسل)
    Dim SentMales As Long, SentFemales As Long, SentUnknown As Long
    Dim SentMalesAmount As Double, SentFemalesAmount As Double, SentUnknownAmount As Double
    Dim SentMalesClients As Object, SentFemalesClients As Object, SentUnknownClients As Object
    Set SentMalesClients = CreateObject("Scripting.Dictionary")
    Set SentFemalesClients = CreateObject("Scripting.Dictionary")
    Set SentUnknownClients = CreateObject("Scripting.Dictionary")

    ' متغيرات للحوالات المصروفة (من العمود S - نوع المرسل إليه)
    Dim PaidMales As Long, PaidFemales As Long, PaidUnknown As Long
    Dim PaidMalesAmount As Double, PaidFemalesAmount As Double, PaidUnknownAmount As Double
    Dim PaidMalesClients As Object, PaidFemalesClients As Object, PaidUnknownClients As Object
    Set PaidMalesClients = CreateObject("Scripting.Dictionary")
    Set PaidFemalesClients = CreateObject("Scripting.Dictionary")
    Set PaidUnknownClients = CreateObject("Scripting.Dictionary")

    Dim i As Long
    Dim ClientName As String, Gender As String, NationalID As String
    Dim Amount As Double

    ' --- تحليل الحوالات المسحوبة (الصادرة) ---
    For i = 2 To LastRowMain
        ClientName = Trim(wsMain.Cells(i, "A").Value)
        NationalID = Trim(wsMain.Cells(i, "B").Value)
        Gender = Trim(wsMain.Cells(i, "I").Value)
        Amount = 0
        If IsNumeric(wsMain.Cells(i, "F").Value) Then Amount = wsMain.Cells(i, "F").Value

        ' تجاهل الصفوف الفارغة
        If ClientName <> "" And NationalID <> "" Then
            Select Case Gender
                Case "ذكر"
                    SentMales = SentMales + 1
                    SentMalesAmount = SentMalesAmount + Amount
                    If Not SentMalesClients.Exists(NationalID) Then SentMalesClients.Add NationalID, 1
                Case "أنثى"
                    SentFemales = SentFemales + 1
                    SentFemalesAmount = SentFemalesAmount + Amount
                    If Not SentFemalesClients.Exists(NationalID) Then SentFemalesClients.Add NationalID, 1
                Case Else
                    SentUnknown = SentUnknown + 1
                    SentUnknownAmount = SentUnknownAmount + Amount
                    If Not SentUnknownClients.Exists(NationalID) Then SentUnknownClients.Add NationalID, 1
            End Select
        End If
    Next i

    ' --- تحليل الحوالات المصروفة ---
    For i = 2 To LastRowMain
        ClientName = Trim(wsMain.Cells(i, "K").Value)
        NationalID = Trim(wsMain.Cells(i, "L").Value)
        Gender = Trim(wsMain.Cells(i, "S").Value)
        Amount = 0
        If IsNumeric(wsMain.Cells(i, "N").Value) Then Amount = wsMain.Cells(i, "N").Value

        ' تجاهل الصفوف الفارغة
        If ClientName <> "" And NationalID <> "" Then
            Select Case Gender
                Case "ذكر"
                    PaidMales = PaidMales + 1
                    PaidMalesAmount = PaidMalesAmount + Amount
                    If Not PaidMalesClients.Exists(NationalID) Then PaidMalesClients.Add NationalID, 1
                Case "أنثى"
                    PaidFemales = PaidFemales + 1
                    PaidFemalesAmount = PaidFemalesAmount + Amount
                    If Not PaidFemalesClients.Exists(NationalID) Then PaidFemalesClients.Add NationalID, 1
                Case Else
                    PaidUnknown = PaidUnknown + 1
                    PaidUnknownAmount = PaidUnknownAmount + Amount
                    If Not PaidUnknownClients.Exists(NationalID) Then PaidUnknownClients.Add NationalID, 1
            End Select
        End If
    Next i

    ' --- إجماليات ---
    Dim TotalSent As Long, TotalPaid As Long
    Dim TotalSentAmount As Double, TotalPaidAmount As Double
    TotalSent = SentMales + SentFemales + SentUnknown
    TotalPaid = PaidMales + PaidFemales + PaidUnknown
    TotalSentAmount = SentMalesAmount + SentFemalesAmount + SentUnknownAmount
    TotalPaidAmount = PaidMalesAmount + PaidFemalesAmount + PaidUnknownAmount

    ' --- كتابة النتائج في ورقة Gender Male Female ---

    ' عناوين الجدول الأول (الحوالات المصدرة)
    With wsGender
        .Range("A4:G4").Value = Array("بيان التعاملات", "عدد العمليات", "نسبة العمليات", "عدد عملاء", "نسبة العملاء", "إجمالي المبالغ", "نسبة المبالغ")

        ' بيانات الذكور (الصادرة)
        .Range("A5").Value = "ذكر"
        .Range("B5").Value = SentMales
        .Range("C5").Value = IIf(TotalSent > 0, SentMales / TotalSent, 0)
        .Range("D5").Value = SentMalesClients.count
        .Range("E5").Value = IIf((SentMalesClients.count + SentFemalesClients.count + SentUnknownClients.count) > 0, SentMalesClients.count / (SentMalesClients.count + SentFemalesClients.count + SentUnknownClients.count), 0)
        .Range("F5").Value = SentMalesAmount
        .Range("G5").Value = IIf(TotalSentAmount > 0, SentMalesAmount / TotalSentAmount, 0)

        ' بيانات الإناث (الصادرة)
        .Range("A6").Value = "انثي"
        .Range("B6").Value = SentFemales
        .Range("C6").Value = IIf(TotalSent > 0, SentFemales / TotalSent, 0)
        .Range("D6").Value = SentFemalesClients.count
        .Range("E6").Value = IIf((SentMalesClients.count + SentFemalesClients.count + SentUnknownClients.count) > 0, SentFemalesClients.count / (SentMalesClients.count + SentFemalesClients.count + SentUnknownClients.count), 0)
        .Range("F6").Value = SentFemalesAmount
        .Range("G6").Value = IIf(TotalSentAmount > 0, SentFemalesAmount / TotalSentAmount, 0)

        ' بيانات غير المحدد (الصادرة)
        .Range("A7").Value = "غير محدد"
        .Range("B7").Value = SentUnknown
        .Range("C7").Value = IIf(TotalSent > 0, SentUnknown / TotalSent, 0)
        .Range("D7").Value = SentUnknownClients.count
        .Range("E7").Value = IIf((SentMalesClients.count + SentFemalesClients.count + SentUnknownClients.count) > 0, SentUnknownClients.count / (SentMalesClients.count + SentFemalesClients.count + SentUnknownClients.count), 0)
        .Range("F7").Value = SentUnknownAmount
        .Range("G7").Value = IIf(TotalSentAmount > 0, SentUnknownAmount / TotalSentAmount, 0)

        ' الإجمالي (الصادرة)
        .Range("A8").Value = "الاجمالى"
        .Range("B8").Value = TotalSent
        .Range("C8").Value = 1
        .Range("D8").Value = SentMalesClients.count + SentFemalesClients.count + SentUnknownClients.count
        .Range("E8").Value = 1
        .Range("F8").Value = TotalSentAmount
        .Range("G8").Value = 1

        ' عناوين الجدول الثاني (الحوالات المصروفة)
        .Range("A10:G10").Value = Array("بيان التعاملات", "عدد العمليات", "نسبة العمليات", "عدد عملاء", "نسبة العملاء", "إجمالي المبالغ", "نسبة المبالغ")

        ' بيانات الذكور (المصروفة)
        .Range("A11").Value = "ذكر"
        .Range("B11").Value = PaidMales
        .Range("C11").Value = IIf(TotalPaid > 0, PaidMales / TotalPaid, 0)
        .Range("D11").Value = PaidMalesClients.count
        .Range("E11").Value = IIf((PaidMalesClients.count + PaidFemalesClients.count + PaidUnknownClients.count) > 0, PaidMalesClients.count / (PaidMalesClients.count + PaidFemalesClients.count + PaidUnknownClients.count), 0)
        .Range("F11").Value = PaidMalesAmount
        .Range("G11").Value = IIf(TotalPaidAmount > 0, PaidMalesAmount / TotalPaidAmount, 0)

        ' بيانات الإناث (المصروفة)
        .Range("A12").Value = "انثي"
        .Range("B12").Value = PaidFemales
        .Range("C12").Value = IIf(TotalPaid > 0, PaidFemales / TotalPaid, 0)
        .Range("D12").Value = PaidFemalesClients.count
        .Range("E12").Value = IIf((PaidMalesClients.count + PaidFemalesClients.count + PaidUnknownClients.count) > 0, PaidFemalesClients.count / (PaidMalesClients.count + PaidFemalesClients.count + PaidUnknownClients.count), 0)
        .Range("F12").Value = PaidFemalesAmount
        .Range("G12").Value = IIf(TotalPaidAmount > 0, PaidFemalesAmount / TotalPaidAmount, 0)

        ' بيانات غير المحدد (المصروفة)
        .Range("A13").Value = "غير محدد"
        .Range("B13").Value = PaidUnknown
        .Range("C13").Value = IIf(TotalPaid > 0, PaidUnknown / TotalPaid, 0)
        .Range("D13").Value = PaidUnknownClients.count
        .Range("E13").Value = IIf((PaidMalesClients.count + PaidFemalesClients.count + PaidUnknownClients.count) > 0, PaidUnknownClients.count / (PaidMalesClients.count + PaidFemalesClients.count + PaidUnknownClients.count), 0)
        .Range("F13").Value = PaidUnknownAmount
        .Range("G13").Value = IIf(TotalPaidAmount > 0, PaidUnknownAmount / TotalPaidAmount, 0)

        ' الإجمالي (المصروفة)
        .Range("A14").Value = "الاجمالى"
        .Range("B14").Value = TotalPaid
        .Range("C14").Value = 1
        .Range("D14").Value = PaidMalesClients.count + PaidFemalesClients.count + PaidUnknownClients.count
        .Range("E14").Value = 1
        .Range("F14").Value = TotalPaidAmount
        .Range("G14").Value = 1

        ' الإجمالي العام (من B15 إلى G15)
        .Range("A15").Value = "الإجمالى العام"
        .Range("B15").Value = TotalSent + TotalPaid
        .Range("C15").Value = 1 ' النسبة الكلية دائمًا 100%
        .Range("D15").Value = SentMalesClients.count + SentFemalesClients.count + SentUnknownClients.count + PaidMalesClients.count + PaidFemalesClients.count + PaidUnknownClients.count
        .Range("E15").Value = 1
        .Range("F15").Value = TotalSentAmount + TotalPaidAmount
        .Range("G15").Value = 1
    End With

    ' --- تنسيق النسب كنسبة مئوية ---
    With wsGender
        .Range("C5:C8, G5:G8").NumberFormat = "0.00%"
        .Range("C11:C14, G11:G14").NumberFormat = "0.00%"
        .Range("C15, G15").NumberFormat = "0.00%"
        .Range("F5:F8, F11:F14, F15").NumberFormat = "#,##0.00"
    End With

    MsgBox "تم تحديث تقرير النوع بنجاح!", vbInformation

End Sub
  

 

النسخه النهائيه(2).xlsm

تم تعديل يوليو 29 بواسطه hegazee

[fantap]

شكرا جزيلا علي الرد

ولكن النتائج بتظر بهذا الشكل لا أدري أين المشكله

[hegazee]

تأكد من إعدادت اللغة للجهاز و أن اللغة العربية ممكنة

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

تم تعديل يوليو 29 بواسطه hegazee

[fantap]

شكرا  جزيلا  تم حل  المشكله   بارك الله فيك