T4190_Fill Invoice Get Count SUM Unique Items

https://excel-egy.com/forum/t4190
---------------------------------

Sub Fill_Invoice_Get_Count_SUM_Unique_Items()
    Dim a, e, x, ws As Worksheet, wTot As Double, dTot As Double, i As Long, j As Long, lr As Long
    Const sInvoice As String = "Invoice"

    Application.ScreenUpdating = False
        Set ws = ThisWorkbook.Worksheets(1)
        a = ws.Range("A2:A" & ws.Cells(Rows.Count, 1).End(xlUp).Row).Value

        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1

            For Each e In a
                If e <> "" Then
                    For Each x In Split(e, "|")
                        .item(Trim(x)) = .item(Trim(x)) + 1
                    Next x
                End If
            Next e

            a = Application.Transpose(Array(.Keys, .Items))
            ReDim Preserve a(1 To UBound(a, 1), 1 To 3)

            For i = LBound(a) To UBound(a)
                a(i, 3) = Application.Round(Application.SumIf(ws.Columns(1), a(i, 1), ws.Columns(2)), 3)
            Next i

            ReDim b(1 To UBound(a, 1) * 2, 1 To 4)
            i = 0

            For j = LBound(b) To UBound(b) Step 2
                i = i + 1
                b(j, 1) = "*"
                b(j, 2) = a(i, 1) & " عدد " & a(i, 2) & " عميل"
                b(j, 3) = GetDecimal(a(i, 3))
                b(j, 4) = Int(a(i, 3))
            Next j
        End With

        Application.DisplayAlerts = False
            If Evaluate("ISREF('" & sInvoice & "'!A1)") Then ThisWorkbook.Worksheets(sInvoice).Delete
        Application.DisplayAlerts = True
        ThisWorkbook.Worksheets("Template").Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        ActiveSheet.Name = sInvoice

        With ThisWorkbook.Worksheets(sInvoice)
            .Rows(14).Resize(UBound(b) - 2).Insert
            .Range("B13").Resize(UBound(b, 1), UBound(b, 2)).Value = b
            .Range("B7").Value = "الكويت في : " & Format(Date, "yyyy/mm/dd")
            lr = .Cells(Rows.Count, 2).End(xlUp).Row - 1

            With .Range("B" & lr + 1)
                .Offset(, 1).Formula = "=MOD(SUM(D13:D" & lr & "),1000)"
                .Offset(, 2).Formula = "=SUM(E13:E" & lr & ")+QUOTIENT(SUM(D13:D" & lr & "),1000)"

                dTot = .Offset(, 1).Value: wTot = .Offset(, 2).Value
                .Value = "الإجمالي: مبلغ وقدره / " & Replace(Ar_WriteDownNumber(CStr(Int(wTot)), "دينار"), "و ", "و") & IIf(dTot = 0, " فقط لا غير", " & " & dTot & " فلس فقط لا غير")
            End With
        End With
    Application.ScreenUpdating = True
End Sub

Function GetDecimal(ByVal num As Double) As String
    GetDecimal = Int((num - (Abs(num) / num) * Int(Abs(num))) * 1000)
End Function

'----------------------------------------------------------------

Public Function Ar_WriteDownNumber(Number_Value As String, Optional Main_Currency As String, Optional Small_Currency As String, Optional Main_To_Small_Factor As Integer)
    Dim myNumber, myFractions, wordFraction, pr, hu, th, prTh, huTh, prMi, huMi, hu1, pr2, l, thu_Text As String, mil_Text As String

    If Val(Main_To_Small_Factor) = 0 Then Main_To_Small_Factor = 100

    If Small_Currency = "" Then
        If Main_To_Small_Factor = 100 Then
            Small_Currency = " جزء من مائة"
        Else
            Small_Currency = " جزء من ألف"
        End If
    End If

    myNumber = Abs(Number_Value)
    myNumber = Int(myNumber)

    If InStr(Number_Value, ".") > 0 Then
        myFractions = Mid(Number_Value, InStr(Number_Value, ".") + 1, 3)
    End If

    l = Len(myNumber)
    pr = Right(myNumber, 2)
    Ar_WriteDownNumber = MyPrimary(pr)

    If l > 2 Then
        hu = Right(Left(myNumber, l - 2), 1)

        If Val(hu) <> 0 Then
            If Ar_WriteDownNumber <> 0 Then
                Ar_WriteDownNumber = MyHundreds(hu) & " و " & Ar_WriteDownNumber
            Else
                Ar_WriteDownNumber = MyHundreds(hu)
            End If
        End If
    Else
        GoTo 1
    End If

    If l > 3 Then
        th = Right(Left(myNumber, l - 3), 2)

        If Val(th) <> 0 Then
            thu_Text = ""

            If Ar_WriteDownNumber <> 0 Then
                Ar_WriteDownNumber = MyThousand(th) & " و " & Ar_WriteDownNumber
            Else
                Ar_WriteDownNumber = MyThousand(th)
            End If
        Else
            thu_Text = " ألف"
        End If
    Else
        GoTo 1
    End If

    If l > 5 Then
        huTh = Right(Left(myNumber, l - 5), 1)

        If Val(huTh) <> 0 Then
            If Ar_WriteDownNumber <> 0 Then
                Ar_WriteDownNumber = MyHundreds(huTh) & thu_Text & " و " & Ar_WriteDownNumber
            Else
                Ar_WriteDownNumber = MyHundreds(huTh) & thu_Text
            End If
        End If
    Else
        GoTo 1
    End If

    If l > 6 Then
        prTh = Right(Left(myNumber, l - 6), 2)

        If Val(prTh) <> 0 Then
            mil_Text = ""
            If Ar_WriteDownNumber <> 0 Then
                Ar_WriteDownNumber = MillionPrimary(prTh) & " و " & Ar_WriteDownNumber
            Else
                Ar_WriteDownNumber = MillionPrimary(prTh) & mil_Text
            End If
        Else
            mil_Text = " مليون"
        End If
    Else
        GoTo 1
    End If

    If l > 8 Then
        huMi = Right(Left(myNumber, l - 8), 1)

        If Ar_WriteDownNumber <> 0 Then
            Ar_WriteDownNumber = MyHundreds(huMi) & mil_Text & " و " & Ar_WriteDownNumber
        Else
            Ar_WriteDownNumber = MyHundreds(huMi) & mil_Text
        End If
    End If

    If l > 9 Then Ar_WriteDownNumber = myNumber

1:
    If Len(Trim(Ar_WriteDownNumber)) > 0 Then
        Ar_WriteDownNumber = Ar_WriteDownNumber & " " & Main_Currency
    Else
        Ar_WriteDownNumber = ""
    End If

    If Len(myFractions) < 2 Then myFractions = myFractions + "0"
    If Len(myFractions) < 3 Then myFractions = myFractions + "0"
    If Val(myFractions) = 0 Then Exit Function

    If Main_To_Small_Factor = 100 Then
        pr2 = Left(myFractions, 2)
    Else
        pr2 = Mid(myFractions, 2, 2)
    End If

    wordFraction = MyPrimary(pr2)

    If Main_To_Small_Factor > 100 Then
        hu1 = Left(myFractions, 1)

        If Val(hu1) <> 0 Then
            If wordFraction <> 0 Then
                wordFraction = MyHundreds(hu1) & " و " & wordFraction
            Else
                wordFraction = MyHundreds(hu1)
            End If
        End If
    Else
        GoTo 2
    End If

2:
    If Main_Currency <> "" Then
        If Len(Trim(Ar_WriteDownNumber)) > 0 Then

            Ar_WriteDownNumber = Ar_WriteDownNumber & " و " & wordFraction & " " & Small_Currency
        Else
            Ar_WriteDownNumber = wordFraction & " " & Small_Currency
        End If
    Else
        If Len(Trim(Ar_WriteDownNumber)) > 0 Then

            If Main_To_Small_Factor = 100 Then
                Small_Currency = " جزء من مائة"
            Else
                Small_Currency = " جزء من ألف"
            End If

            Ar_WriteDownNumber = Ar_WriteDownNumber & " فاصل " & wordFraction
        Else
            Ar_WriteDownNumber = wordFraction & " " & Small_Currency
        End If
    End If
End Function

Private Function MyPrimary(j)
    Dim myText1, myText2, k

    k = Right(j, 1): j = Val(j)

    If j < 20 Then
        MyPrimary = Choose(j, "واحد", "اثنان", "ثلاثة", "أربعة", "خمسة", "ستة", "سبعة", "ثمانية", "تسعة", "عشرة", "إحدى عشر", "اثنا عشر", "ثلاثة عشر", "أربعة عشر", "خمسة عشر", "ستة عشر", "سبعة عشر", "ثمانية عشر", "تسعة عشر")
    Else
        myText1 = Choose(Val(k), "واحد", "اثنان", "ثلاثة", "أربعة", "خمسة", "ستة", "سبعة", "ثمانية", "تسعة")
        myText2 = Choose(Int((j - k) / 10) - 1, "عشرون", "ثلاثون", "أربعون", "خمسون", "ستون", "سبعون", "ثمانون", "تسعون")

        If Not IsNull(myText1) Then
            MyPrimary = myText1 & " و " & myText2
        Else
            MyPrimary = myText2
        End If
    End If
End Function

Private Function MyHundreds(j)
    j = Val(j)

    MyHundreds = Choose(j, "مائة", "مائتان", "ثلاثمائة", "أربعمائة", "خمسمائة", "ستمائة", "سبعمائة", "ثمانمائة", "تسعمائة")
End Function

Private Function MyThousand(j)
    Dim myText1, myText2, k

    k = Right(j, 1): j = Val(j)

    If j < 20 Then
        MyThousand = Choose(j, "ألف", "ألفان", "ثلاثة آلاف", "أربعة آلاف", "خمسة آلاف", "ستة آلاف", "سبعة آلاف", "ثمانية آلاف", "تسعة آلاف", "عشرة آلاف", "إحدى عشر ألفاً", "اثنا عشر ألفاً", "ثلاثة عشر ألفاً", "أربعة عشر ألفاً", "خمسة عشر ألفاً", "ستة عشر ألفاً", "سبعة عشر ألفاً", "ثمانية عشر ألفاً", "تسعة عشر ألفاً")
    Else
        myText1 = Choose(k, "واحد", "اثنان", "ثلاثة", "أربعة", "خمسة", "ستة", "سبعة", "ثمانية", "تسعة")
        myText2 = Choose((j - k) / 10 - 1, "عشرون", "ثلاثون", "أربعون", "خمسون", "ستون", "سبعون", "ثمانون", "تسعون")

        If Not IsNull(myText1) Then
            MyThousand = myText1 & " و" & myText2 & " ألف"
        Else
            MyThousand = myText2 & " ألف"
        End If
    End If
End Function

Private Function MillionPrimary(j)
    Dim myText1, myText2, k

    k = Right(j, 1): j = Val(j)

    If j < 20 Then
        MillionPrimary = Choose(j, "مليون", "مليونان", "ثلاثة ملايين", "أربعة ملايين", "خمسة ملايين", "ستة ملايين", "سبعة ملايين", "ثمانية ملايين", "تسعة ملايين", "عشرة ملايين", "إحدى عشر مليونأ", "اثنا عشر مليون", "ثلاثة عشر مليون", "أربعة عشر مليون", "خمسة عشر مليون", "ستة عشر مليون", "سبعة عشر مليون", "ثمانية عشر مليون", "تسعة عشر مليون")
    Else
        myText1 = Choose(Val(k), "واحد", "اثنان", "ثلاثة", "أربعة", "خمسة", "ستة", "سبعة", "ثمانية", "تسعة")
        myText2 = Choose(Int((j - k) / 10) - 1, "عشرون مليون", "ثلاثون مليون", "أربعون مليون", "خمسون مليون", "ستون مليون", "سبعون مليون", "ثمانون مليون", "تسعون مليون")

        If Not IsNull(myText1) Then
            MillionPrimary = myText1 & " و " & myText2
        Else
            MillionPrimary = myText2
        End If
    End If
End Function