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

fantap · الإثنين at 20:00

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

?dm=6LHN0S9Z

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

تم تعديل الإثنين at 20:04 بواسطه fantap

hegazee · منذ 18 ساعات

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

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

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

تم تعديل منذ 18 ساعات بواسطه hegazee

fantap · منذ 17 ساعات

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

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

?dm=6DN9OI2O

hegazee · منذ 13 ساعات

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

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

تم تعديل منذ 13 ساعات بواسطه hegazee

fantap · منذ 12 ساعات

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

تسجيل الدخول

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

الردود الموصى بها

fantap

hegazee

fantap

hegazee

fantap

Join the conversation

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

تصفح الموقع

تصفح جديد الموقع

Support

Important Information