لاضافة ماكرو بالورود او بالاكسل اليك الخطوات التالية :
1- ادوات ثم ماكرو ثم محرر فيجوال بيسك وبعد فتح المحرر ارجع الى ادوات ثم اختر انشاء ماكرو جديد باي اسم فيرجع بك الى المحرر حدد جميع النص المنشأ الياً بواسطة المحرر واستبدله بالكود المراد استخدامه .
2- ثم لاستخدام الكود المضاف ستجد هناك اختلاف بين الورد والاكسل حيث انه بالاكسل ستستدعي الكود من خلال الدالة او الاجراء الرئسي فيه وذلك بشريط الصيغ مثلا لاستدعاء كود التفقيط بشريط الصيع اتبع الاتي: 

1- اكتب اي رقم بالخانة : A1
ب- ثم انزل للخانة التي تليها ولصق النص التالي بشريط الصيغ فتظهر معك النتيجة
=ToWordsArb(A1)

3- اما عن طريق الوورد فتوجه ايضا الى ادوات ثم اطلب تشغيل ماكرو وستجد اسم الماكرو او الاجراء فقم باختياره .


-----------<( بداية الكود)>-----------
    Function ToWordsArb(ByVal Num As String) As String
        Dim S1 As String, S2 As String, S3 As String, Tmp As String, X As String
        Dim L As Integer, T As Integer, R As Integer, T_ As String
        Const S As String = " " : Const O As String = " و "
        T_ = "الاف"


        'Fill Array'''''''''''''''''''(1 to 9)'''''''''''''''''''''
       Dim AN(0 To 9) As String 'Data for conversion
        AN(1) = "واحد" : AN(2) = "اثنان" : AN(3) = "ثلاثة"
        AN(4) = "اربعة" : AN(5) = "خمسة" : AN(6) = "ستة"
        AN(7) = "سبعة" : AN(8) = "ثمانية" : AN(9) = "تسعة"
        ''''''''''''''''''''(11 to 19 )'''''''''''''''''''''''''''''
       Dim BN(0 To 9) As String
        BN(0) = "عشرة"
        BN(1) = "احد عشر" : BN(2) = "اثنا عشر" : BN(3) = "ثلاثة عشر"
        BN(4) = "اربع عشر" : BN(5) = "خمسة عشر" : BN(6) = "ستة عشر"
        BN(7) = "سبعة عشر" : BN(8) = "ثمانية عشر" : BN(9) = "تسعة عشر"
        ''''''''''''''''''''(10 to 90)'''''''''''''''''''''''''''''''''''
       Dim CN(0 To 9) As String
        CN(1) = "عشرة" : CN(2) = "عشرين" : CN(3) = "ثلاثين"
        CN(4) = "اربعين" : CN(5) = "خمسين" : CN(6) = "ستين"
        CN(7) = "سبعين" : CN(8) = "ثمانين" : CN(9) = "تسعين"
        ''''''''''''''''''''(100 to 900)'''''''''''''''''''''''''''''''''''
       Dim DN(0 To 9) As String
        DN(1) = "مائة" : DN(2) = "مائتين" : DN(3) = "ثلاث مائة"
        DN(4) = "اربع مائة" : DN(5) = "خمس مائة" : DN(6) = "ست مائة"
        DN(7) = "سبع مائة" : DN(8) = "ثمان مائة" : DN(9) = "تسع مائة"
        'ZEROs''''''''''''''''''''''''''''''
        AN(0) = "" : BN(0) = "عشرة" : CN(0) = "" : DN(0) = ""
        'Make redey''''''''''''''''''''''''''''''

        L = Len(Num)

        '''''''''''''''''''''''''''''''''Check Start: ''''''''''''''''''''''''''''''''''''''''''''
        ''ALL BY ORDER :'''''''''''''''''''''''''''''

        Dim W As Collection, C As Integer, MM As String
        set W = New Collection
        'Split numbers to array
        For T = L To 1 Step -1
            MM = Mid(CStr(Num), T, 1)
            If IsNumeric(MM) Then W.Add(MM)
        Next T
        'Exit if it Zero'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        Num = Replace(Num, "|", "") : If Val(Num) = 0 Then X = "صفر" : GoTo Ex '''
        C = W.Count : L = C 'Very Important                                  '''
        '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

        '1 Check''1 to 9
        If L = 1 Then X = AN(Val(Num)) : GoTo Ex

        '2 Check'11-12-13....To: 19
        If L = 2 Then If Val(W.Item(2)) = 1 Then _
        X = BN(Val(W.Item(1))) : GoTo Ex

        '2 Check'10-20-30....To: 90
        If L = 2 Then If Val(W.Item(1)) = 0 Then _
        X = CN(Val(W.Item(1))) : GoTo Ex

        '3 Check'From 21 ....To: 90
        If L = 2 Then X = AN(Val(W.Item(1))) & O & CN(Val(W.Item(2))) : GoTo Ex

Re_Check:
        '3 Check' The Tow Frist Numbers of Large number:
        If Val(W.Item(2)) = "1" Then 'Elvenths(BN)
            X = BN(Val(Val(W.Item(1))))
        ElseIf Val(W.Item(1)) = "0" Then 'Tointeth(CN)
            X = CN(Val(Val(W.Item(2))))
        Else
            X = AN(Val(W.Item(1))) & O & CN(Val(W.Item(2)))  'From 21-67 ....To: 90
        End If

        X = Zeros(W, X, 2)

        '4 Check ' 12-31-41... to end'''

        If L > 2 Then 'Hundreds(DN)
            X = DN(Val(W.Item(3))) & O & X 'Hundreds & Numbers
            If W.Item(1) = "0" And W.Item(2) = "0" Then X = DN(Val(W.Item(3))) 'Hundreds & Zeros

            X = Zeros(W, X, 3)
        End If
        '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        If L = 4 Then ' Thawsend(1,000)''4 Numbers'''''''''''''''''''''''''''''''

            If Val(W.Item(4)) = 1 Then
                Tmp = "الف"
            ElseIf Val(W.Item(4)) = 2 Then
                Tmp = "الفين"
            Else
                Tmp = "الاف"
            End If

            If Tmp = "الاف" Then X = AN(Val(W.Item(4))) & S & Tmp & O & X Else X = Tmp & O & X 'Thawsend & Numbers

            If W(2) = "0" & W(3) = "0" & W(4) = "0" Then _
            If Tmp = "الاف" Then X = AN(Val(W.Item(1))) & S & Tmp Else X = Tmp 'Thawsend & Zeros

            X = Zeros(W, X, 4)
        End If
        '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        'If L > 4 And L < 8 Then '10 Thawsend(10,000)''5 Numbers'''''''''''''''''''''''''''''''
        If L > 4 Then ''___ OPEN IF ______________________________________________(L > 4)

TenThawsend:  '10 Thawsend(10,000)''5 Numbers'''''''''''''''''''''''''''''''
            Tmp = ""
            If W(5) = "0" Then GoTo HoundredsThawsend 'Jump

            If Val(W.Item(5)) = 1 Then
                Tmp = "عشرة الاف"
            ElseIf Val(W.Item(5)) = 2 Then
                Tmp = "عشرين الف"
            End If


            If W(4) = "0" Then '10.000
                If Val(W.Item(5)) = 1 Or Val(W.Item(5)) = 2 Then X = Tmp & O & X Else _
                T_ = "الف" : X = CN(Val(W(5))) & S & T_ & O & X
            Else '11.000
                T_ = "الف"
                If W(5) = "1" Then X = BN(Val(W(4))) & S & T_ & O & X
                If W(5) <> "1" Then X = AN(Val(W(4))) & O & CN(Val(W(5))) & S & T_ & O & X
            End If

            If L = 5 Then GoTo Ex '100 Thawsend(100,000)''6 Numbers''''''''''''''''''''''''''''''
HoundredsThawsend:

            If W(6) = "0" Then GoTo Mileons 'Jump
            X = Zeros(W, X, 5)

            Tmp = "الف"

            If W(5) = "0" And W(4) = "0" Then
                X = DN(Val(W(6))) & S & Tmp & O & X
            Else
                If W(5) = 0 Then
                    If Val(W(6)) > 2 Then Tmp = "الاف"
                    If Val(W(5)) = 0 Then If Val(W(4)) > 2 Then Tmp = "الاف" Else Tmp = "الف"
                    X = DN(Val(W(6))) & O & AN(Val(W(4))) & S & Tmp & O & X 'tx here
                Else
                    X = DN(Val(W(6))) & O & X
                End If
            End If
            X = Replace(X, "مائتين الف", "مئتي الف")
            X = Replace(X, " الف الف ", " الف ")

            If L < 7 Then GoTo Ex 'Milon(1000,000)''7 numbers'''''''''''''''''''''''''''''''
Mileons:

            If Val(W.Item(7)) < 1 Then GoTo TenMileons 'Jump
            If L > 7 Then If Val(W.Item(8)) <> 0 Then GoTo TenMileons 'Jump
            If L > 8 Then If Val(W(9)) <> 0 Then GoTo TenMileons 'Jump

            Tmp = "ملاين"


            If Val(W.Item(7)) = 1 Then
                Tmp = "مليون"
            ElseIf Val(W.Item(7)) = 2 Then
                Tmp = "مليونين"
            End If

            X = Zeros(W, X, 6)

            If Val(W.Item(7)) > 2 Then X = AN(Val(W(7))) & S & Tmp & O & X Else X = Tmp & O & X

            If L < 8 Then GoTo Ex 'Milon(10,000,000)''8 numbers'''''''''''''''''''''''''''''''
TenMileons:
            If L > 8 Then If Val(W(9)) <> 0 Or Val(W(8)) < 1 Then GoTo HoundredsMileons 'Jump

            If Val(W(8)) = 1 Then Tmp = "ملاين" Else Tmp = "مليون"

            X = Zeros(W, X, 6)
            X = Zeros(W, X, 7)

            If Val(W(8)) = 1 Then 'Tenth Mileons:10,000,000
                If Val(W(7)) = 0 Then X = CN(Val(W(8))) & S & Tmp & O & X Else _
                Tmp = "مليون" : X = BN(Val(W(7))) & S & Tmp & O & X 'Elventh Mileons
            Else
                If Val(W(7)) = 0 Then X = CN(Val(W(8))) & S & Tmp & O & X Else _
                 X = AN(Val(W(7))) & O & CN(Val(W(8))) & S & Tmp & O & X '12,000,000
            End If

            If L < 9 Then GoTo Ex 'Milon(100,000,000)''9 numbers'''''''''''''''''''''''''''''''
HoundredsMileons:
            If L > 9 And Val(W(9)) < 1 Then GoTo Bileon

            Tmp = "مليون"
            X = Zeros(W, X, 8)

            If Val(W(7)) = 0 And Val(W(8)) = 0 Then    '100,000,000
                X = DN(Val(W(9))) & S & Tmp & O & X 'Puer Houndreds Of Mileons
            Else '110,000,000
                '1- Houndreds Of Mileons & Elvenths : ..2- Else :Houndreds Of Mileons & Frist numbers
                If Val(W(8)) = 1 Then X = DN(Val(W(9))) & O & BN(Val(W(7))) & S & Tmp & O & X Else _
                X = DN(Val(W(9))) & O & AN(Val(W(7))) & S & O & CN(Val(W(8))) & S & Tmp & O & X
            End If
            X = Replace(X, "مائتين مليون", "مئتي مليون")

            If L < 10 Then GoTo Ex 'Bileon(1,000,000,000)''10 numbers'''''''''''''''''''''''''''''''
Bileon:

            If Val(W.Item(10)) < 1 Then GoTo Ten_Of_Bileons 'Jump
            If L > 10 Then If Val(W.Item(11)) <> 0 Then GoTo Ten_Of_Bileons 'Jump
            If L > 11 Then If Val(W(12)) <> 0 Then GoTo Ten_Of_Bileons 'Jump


            Tmp = "بلاين"

            If Val(W.Item(10)) = 1 Then
                Tmp = "بليون"
            ElseIf Val(W.Item(10)) = 2 Then
                Tmp = "بليونين"
            End If

            X = Zeros(W, X, 9)

            If Val(W.Item(10)) > 2 Then X = AN(Val(W(10))) & S & Tmp & O & X Else X = Tmp & O & X

            If L < 11 Then GoTo Ex 'Bileon(10,000,000,000)''11 numbers'''''''''''''''''''''''''''''''
Ten_Of_Bileons:

            If L > 11 Then If Val(W(12)) <> 0 Or Val(W(11)) < 1 Then GoTo Houndred_Of_Bileons 'Jump

            If Val(W(11)) = 1 Then Tmp = "بلاين" Else Tmp = "بليون"

            X = Zeros(W, X, 11)

            If Val(W(11)) = 1 Then 'Tenth Bileons:10,000,000,000
                If Val(W(10)) = 0 Then X = CN(Val(W(11))) & S & Tmp & O & X Else _
                Tmp = "بليون" : X = BN(Val(W(10))) & S & Tmp & O & X 'Elventh Bileons
            Else
                If Val(W(10)) = 0 Then X = CN(Val(W(11))) & S & Tmp & O & X Else _
                 X = AN(Val(W(10))) & O & CN(Val(W(11))) & S & Tmp & O & X '12,000,000,000
            End If

            If L < 12 Then GoTo Ex 'Bileon(100,000,000,000)''12 numbers'''''''''''''''''''''''''''''''
Houndred_Of_Bileons:
            If L > 12 And Val(W(12)) < 1 Then GoTo Trlion

            Tmp = "بليون"
            X = Zeros(W, X, 12)

            If Val(W(10)) = 0 And Val(W(11)) = 0 Then    '100,000,000,000
                X = DN(Val(W(12))) & S & Tmp & O & X 'Puer Houndreds Of Bileons
            Else '110,000,000,000
                '1- Houndreds Of Bileons & Elvenths : ..2- Else :Houndreds Of Bileons & Frist numbers
                If Val(W(11)) = 1 Then X = DN(Val(W(12))) & O & BN(Val(W(10))) & S & Tmp & O & X Else _
                X = DN(Val(W(12))) & O & AN(Val(W(10))) & S & O & CN(Val(W(11))) & S & Tmp & O & X
            End If

            X = Replace(X, "مائتين بليون", "مئتي بليون")

            If L < 13 Then GoTo Ex 'Trlion(1,000,000,000,000)''13 numbers'''''''''''''''''''''''''''''''
Trlion:

            If Val(W.Item(13)) < 1 Then GoTo Ten_Of_Trlions 'Jump
            If L > 13 Then If Val(W.Item(14)) <> 0 Then GoTo Ten_Of_Trlions 'Jump
            If L > 14 Then If Val(W.Item(15)) <> 0 Then GoTo Ten_Of_Trlions 'Jump


            Tmp = "تريلونات"

            If Val(W.Item(13)) = 1 Then
                Tmp = "ترليون"
            ElseIf Val(W.Item(13)) = 2 Then
                Tmp = "ترليونين"
            End If


            X = Zeros(W, X, 13)
            If Val(W.Item(13)) > 2 Then X = AN(Val(W(13))) & S & Tmp & O & X Else X = Tmp & O & X

            If L < 14 Then GoTo Ex 'Ten_Of_Trlions(10,000,000,000,000)''14 numbers'''''''''''''''''''''''''''''''
Ten_Of_Trlions:

            If L > 14 Then If Val(W(15)) <> 0 Or Val(W(14)) < 1 Then GoTo Houndreds_Of_Trlions 'Jump

            If Val(W(14)) = 1 Then Tmp = "تريلونات" Else Tmp = "ترليون"

            X = Zeros(W, X, 14)

            If Val(W(14)) = 1 Then 'Tenth Trlions:10,000,000,000,000
                If Val(W(13)) = 0 Then X = CN(Val(W(14))) & S & Tmp & O & X Else _
                Tmp = "ترليون" : X = BN(Val(W(13))) & S & Tmp & O & X 'Elventh Trlions
            Else
                If Val(W(13)) = 0 Then X = CN(Val(W(14))) & S & Tmp & O & X Else _
                 X = AN(Val(W(13))) & O & CN(Val(W(14))) & S & Tmp & O & X '12,000,000,000,000
            End If

            If L < 15 Then GoTo Ex 'Houndreds_Of_Trlions(100,000,000,000,000)''15 numbers'''''''''''''''''''''''''''''''
Houndreds_Of_Trlions:
            If L > 15 And Val(W(15)) < 1 Then GoTo Quadrillion

            Tmp = "ترليون"
            X = Zeros(W, X, 15)

            If Val(W(13)) = 0 And Val(W(14)) = 0 Then    '100,000,000,000,000
                X = DN(Val(W(15))) & S & Tmp & O & X 'Puer Houndreds Of Trlions
            Else '110,000,000,000,000
                '1- Houndreds Of Trlions & Elvenths : ..2- Else :Houndreds Of Trlions & Frist numbers
                If Val(W(14)) = 1 Then X = DN(Val(W(15))) & O & BN(Val(W(13))) & S & Tmp & O & X Else _
                X = DN(Val(W(15))) & O & AN(Val(W(13))) & S & O & CN(Val(W(14))) & S & Tmp & O & X
            End If

            X = Replace(X, "مائتين ترليون", "مئتي ترليون")

            If L < 16 Then GoTo Ex 'Quadrillion(1,000,000,000,000,000)''16 numbers'''''''''''''''''''''''''''''''
Quadrillion:

            If Val(W.Item(16)) < 1 Then GoTo Ten_Of_Quadrillions 'Jump
            If L > 16 Then If Val(W.Item(17)) <> 0 Then GoTo Ten_Of_Quadrillions 'Jump
            If L > 17 Then If Val(W.Item(18)) <> 0 Then GoTo Ten_Of_Quadrillions 'Jump


            Tmp = "كوادرليونات"

            If Val(W.Item(16)) = 1 Then
                Tmp = "كوادرليون"
            ElseIf Val(W.Item(16)) = 2 Then
                Tmp = "كوادرليونين"
            End If


            X = Zeros(W, X, 16)
            If Val(W.Item(16)) > 2 Then X = AN(Val(W(16))) & S & Tmp & O & X Else X = Tmp & O & X

            If L < 17 Then GoTo Ex 'Ten_Of_Quadrillions(10,000,000,000,000,000)''17 numbers'''''''''''''''''''''''''''''''
Ten_Of_Quadrillions:

            If L > 17 Then If Val(W(18)) <> 0 Or Val(W(17)) < 1 Then GoTo Houndreds_Of_Quadrillions 'Jump

            If Val(W(17)) = 1 Then Tmp = "كوادرليونات" Else Tmp = "كوادرليون"

            X = Zeros(W, X, 17)

            If Val(W(17)) = 1 Then 'Tenth Quadrillions
                If Val(W(16)) = 0 Then X = CN(Val(W(17))) & S & Tmp & O & X Else _
                Tmp = "كوادرليون" : X = BN(Val(W(16))) & S & Tmp & O & X 'Elventh Quadrillions
            Else
                If Val(W(16)) = 0 Then X = CN(Val(W(17))) & S & Tmp & O & X Else _
                 X = AN(Val(W(16))) & O & CN(Val(W(17))) & S & Tmp & O & X '12,000,000,000,000,000
            End If

            If L < 18 Then GoTo Ex 'Houndreds_Of_Quadrillions(100,000,000,000,000,000)''18 numbers'''''''''''''''''''''''''''''''
Houndreds_Of_Quadrillions:

            If L > 18 And Val(W(18)) < 1 Then GoTo Zlion

            Tmp = "كوادرليون"
            X = Zeros(W, X, 18)

            If Val(W(16)) = 0 And Val(W(17)) = 0 Then    '100,000,000,000
                X = DN(Val(W(18))) & S & Tmp & O & X 'Puer Houndreds Of Quadrillions
            Else '110,000,000,000
                '1- Houndreds Of Quadrillions & Elvenths : ..2- Else :Houndreds Of Quadrillions & Frist numbers
                If Val(W(17)) = 1 Then X = DN(Val(W(18))) & O & BN(Val(W(16))) & S & Tmp & O & X Else _
                X = DN(Val(W(18))) & O & AN(Val(W(16))) & S & O & CN(Val(W(17))) & S & Tmp & O & X
            End If

            X = Replace(X, "مائتين كوادرليون", "مئتي كوادرليون")

            If L < 19 Then GoTo Ex 'Houndreds_Of_Quadrillions(100,000,000,000,000,000)''18 numbers'''''''''''''''''''''''''''''''
Zlion:      '[The end]'''Last Naming number
            X = "" : X = "زليون" & vbCrLf & "الزليون : رقم غير محدود يفوق التسميات المعروفة"

        End If ''___ CLOSE IF ______________________________________________(L > 4)
        '''''''''''''''''''''''''''''''''Check End: ''''''''''''''''''''''''''''''''''''''''''''''

Ex:
        set W = Nothing
        X = Replace(X, O & O, O) ''Delte extra waws
        'delete last waw
        If Len(X) > 2 Then _
        If Mid(X, Len(X) - 2, 2) = " و" Or Mid(X, Len(X) - 2, 2) = "و " Then X = Left(X, Len(X) - 2)
        ToWordsArb = X
    End Function
    Function Zeros(ByVal Col As Collection, ByVal X As String, ByVal MAX As Integer) As String
        Dim T As Integer, I As Boolean
        If MAX < 1 Then Exit Function
        For T = 1 To Col.Count
            If Val(Col.Item(T)) <> 0 Then I = True : Exit For
            If T = MAX Then Exit For
        Next T
        If I Then Zeros = X Else Zeros = ""
    End Function

-----------<( نهاية الكود)>-----------