الرئيسية / فيجوال بيزك / أكواد VBA مفيدة / كود التفقيط – ج1 اللغة العربية

دالة التفقيط للغة العربية

كود التفقيط – ج1 اللغة العربية

السلام عليكم, يعتبر كود التفقيط من أهم اكواد VBA كونه يحل مشكلة شائعة عند مستخدمي برنامج Excel من مختلف اللغات والمتمثلة بتحويل اي رقم عددي الى نص مما يساهم في حل مشكلة طباعة المستندات المالية رقماً ونصاً كما في حالة الشيكات او الفواتير وماشابه.
اعتقد ان كتابة هكذا كود ليتناسب مع طبيعة اللغة العربية (من تذكير وتأنيث) يُعتبر أمراً صعب جداً فما بالك اذا كان هذا الكود يأخذ بعين الاعتبار امكانية تغيير اسم العملة للرقم الصحيح وكذلك الجزء العشري (الكسر). اعتقد أن المهمة هنا ستكون اصعب واصعب. الكود الذي سأطرحه من كتابة الأستاذ المبدع عبد الله باقشير وقد تم طرحه في موقع أوفيسنا عام 2011. لقد قمت بتعديلات طفيفة جداً على الكود كالتالي,

تغيير اسم الدالة الافتراضي لسهولة الكتابة والتذكر,
تغير القيم الافتراضيّة للدالة للعملة السعودية (لا يوجد عملة افتراضيّة في الكود الاصلي),
تغيير ترتيب مدخلات الدالة لسهولة التذكر.

كود التفقيط:

يمكنك نسخ كود التفقيط من صندوق الكود التالي او تحميل ملف المثال من آخر المقالة,

Option Explicit
'========================================================"
'                بسم الله الرحمن الرحيم                     "

' تم تحميل هذا الكود من الرابط التالي
' http://www.officena.net/ib/topic/39447-%D8%AF%D8%A7%D9%84%D8%A9-%D8%AA%D9%81%D9%82%D9%8A%D8%B7-%D8%AA%D8%AD%D9%88%D9%8A%D9%84-%D8%A7%D9%84%D8%B1%D9%82%D9%85-%D8%A7%D9%84%D9%89-%D9%86%D8%B5-%D8%A8%D8%A7%D9%84%D8%B9%D8%B1%D8%A8%D9%8A-%D8%B7%D9%88%D9%84-%D8%A7%D9%84%D8%B1%D9%82%D9%85-%D8%BA%D9%8A%D8%B1-%D9%85%D8%AD%D8%AF%D9%88%D8%AF/
' الكود من كتابة السيد عبد الله باقشير بتاريخ 27/11/2011
' تم التعديل على اسم الكود مع القيم الافتراضية للتتناسب مع العملة السعودية
' كذلك تم تعديل ترتيب مدخلات الدالة لسهولة الحفظ للمستخدم النهائي
' تم التعديل من قبل حسين بلال بتاريخ 22/2/2016
' husseinb[at]viaexcel.com
' www.viaexcel.com
' CurrText
'========================================================"
'      (دالة تحويل الرقم الى نص باللغة العربية (تفقيط      "
'                     kh_TextNum                         "
'========================================================"
'Num                     الرقم                           "
'========================================================"
'Sex                   جنس العملة                        "
'        FALSE   ( أو فارغ او صفر مذكر )                 "
'        TRUE   (  أو اي رقم غير الصفر مؤنث )             "
'========================================================"
'NCurr_Si        اسم العملة الرئيسية مفرد                "
'NCurr_Pl          اسم العملة الرئيسية جمع                "
'NCurrDec_Si           اسم العملة الكسرية                "
'Decimal_Count  طول الكسر افتراضـياً : بدون اظهار الكسر    "
'========================================================"
'            : للدلالة على تفقيط الكسر عين التالي            "
'NCurrDec_pl       اسم العملة الكسرية جمع                 "
'dSex               جنس عملة الكسر                       "
'        FALSE   ( أو فارغ او صفر مذكر )                 "
'        TRUE   (  أو اي رقم غير الصفر مؤنث )             "
'========================================================"
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"
'                       ملاحظات
'  (اولاً : اذا اسم العملة ينتهي بالتاء المربوطة
'              يجب ان يكتب كذلك وليس بالهاء
'                -----------------------
'      ثانياً : العملة الافتراضية هي العملة السعودية
'               وجنس العملة والكسر مؤنث
'                -----------------------
'("" ثالثاً : امكانية إضافة كلمة بداية ونهاية النص (فارغة
Private Const MyBegTx As String = ""
Private Const MyEndTx As String = " فقط لاغير"
'                -----------------------
' MyTNum  رابعا : يمكنك التغيير (اضافة,حذف,تحرير) في الثابت
'             للفئات الصفرية للرقم ادناه
Private Const MyTNum As String = "ألف-آلاف/مليون-ملايين/مليار-مليارات/بليون-بلايين/بليار-بليارات/ترليون-ترليونات/تريليار-تريليارات/كدرليون-كدرليونات"
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"
'==============================================================================================================================================="
Private Const wow As String * 2 = " و"
'==============================================================================================================================================="

Function CurrText(Num As String, _
Optional Sex As Boolean = True, _
Optional NCurr_Si As String = "ريال", _
Optional NCurr_Pl As String = "ريالات", _
Optional dSex As Boolean = True, _
Optional NCurrDec_Si As String = "هللة", _
Optional NCurrDec_Pl As String = "هللات", _
Optional Decimal_Count As Byte = 2) _
As String
'======================================
Dim Spp, zt
Dim i%, ii%, pr%
Dim MyMid$, nCurr$, Txt$, Txt1$, Txt2$
'======================================
If Not IsNumeric(Num) Then GoTo kh_Exit
If Num = 0 Then Txt = MyBegTx & "صفر " & NCurr_Si: GoTo kh_Exit
'======================================
Spp = Split("/" & MyTNum, "/")
ii = UBound(Spp)
If Num < 0 Then Num = Abs(Num)
'======================================
If Val(Num) > Val(String((ii + 1) * 3, "9") & ".999") Then GoTo kh_Exit
'======================================
nCurr = NCurr_Si & "-" & IIf(NCurr_Pl = "", NCurr_Si, IIf(NCurr_Si = "", "", NCurr_Pl))
'======================================
Txt1 = Format(Num, String((ii + 1) * 3, "0") & ".000")
For i = 0 To ii
    MyMid = Mid(Txt1, (i * 3) + 1, 3)
    If MyMid Then
        zt = Mid(Txt1, (i * 3) + 4, Len(Txt1))
        zt = IIf(ii - i, Int(zt), 1)
        Txt2 = IIf(ii - i, Trim(Spp(ii - i)), nCurr)
        pr = 1 + IIf(ii - i, 1, CInt(Sex))
        Txt = Txt & IIf(Len(Txt), wow, "") & kh_nText(MyMid, Txt2, pr, zt, CBool(NCurr_Si <> ""))
    End If
    If i = ii Then If MyMid = 0 Then Txt = Txt & IIf(Len(Txt), " " & NCurr_Si, IIf(Decimal_Count = 0, "صفر", ""))
Next
'======================================
Txt = MyBegTx & Txt & kh_dText(Num, NCurr_Si, Trim(NCurrDec_Si), Decimal_Count, Trim(NCurrDec_Pl), dSex) & MyEndTx
'======================================
kh_Exit:
CurrText = Trim(Txt)
End Function
'    معالجة العدد من 1 الى 999   لكل فئات الرقم
Private Function kh_nText(ByVal iNum As String, ByVal oMm As String, ByVal ibs As Integer, ByVal Z As Boolean, ByVal tCu As Boolean) As String
Dim Sp
Dim Num1%, Num2%, Num3%
Dim oM$, S$, S1$, nT$, nT0$, nT1$, nT2$
'======================================
Sp = Split("واحد,إحدى,اثنتان,ثلاث,أربع,خمس,ست,سبع,ثمان,تسع,عشر,إحدى ,اثنتا ", ",")
'======================================
If ibs Then S = "ة": Sp(1) = Sp(0): Sp(2) = "اثنان": Sp(11) = "أحد ": Sp(12) = "اثنا " Else S1 = "ة"
oM = Trim(Split(oMm, "-")(0))
'======================================
Num1 = Left(iNum, 1)
Num2 = Right(iNum, 2)
Select Case Num1
    Case 1:      nT0 = "مائة"
    Case 2:      nT0 = "مائتا" & IIf(ibs = 2, IIf(Num2 < 3, "", "ن"), IIf(Num2 = 0 And oM <> "", "", "ن"))
    Case 3 To 9: nT0 = Sp(Num1) & "مائة"
End Select
'=========================================
Num1 = Right(iNum, 2)
Select Case Num1
    Case 1, 2:     If nT0 <> "" Then If ibs = 2 Then nT0 = nT0 & " " & oM
    Case 11 To 99: If oM <> "" Then If ibs Then If Z Then oM = oM & "اً"
End Select
'-----------------------------------------
Select Case Num1
    Case 1
        nT = IIf(oM = "", Sp(0) & S1, oM)
        oM = IIf(ibs <> 2 And oM <> "", Sp(0) & S1, "")
    Case 2
        nT = IIf(oM = "", Sp(Num1), Replace(oM, "ة", "ت") & IIf(Z = 0 And ibs = 2 And tCu, "ا", "ان"))
        oM = IIf(ibs <> 2 And oM <> "", Sp(Num1), "")
    Case 3 To 10
        oM = Trim(Split(oMm, "-")(1))
        nT = Sp(Num1) & S
    Case 11, 12
        nT = Sp(Num1) & Sp(10) & S1
    Case 13 To 19
        nT = Sp(Num1 - 10) & S & " " & Sp(10) & S1
    Case 20 To 99
        Num2 = Right(Num1, 1)
        Num3 = Left(Num1, 1)
        If Num3 = 2 Then nT1 = "عشرون" Else nT1 = Sp(Num3) & "ون"
        nT2 = Sp(Num2) & IIf(Num2 > 2, S, "") & wow & nT1
        If Num2 = 0 Then nT2 = nT1
        nT = nT2
End Select
'======================================
S = IIf(nT = "" Or iNum < 100, "", wow)
nT = Replace(nT, Sp(8) & "ة", Sp(8) & "ية")
kh_nText = Trim(nT0 & S & nT & " " & oM)
'======================================
End Function
'            معالجة الكسر
Private Function kh_dText(ByVal dNum As String, ByVal NCur As String, ByVal Ndec As String, ByVal co As Byte, ByVal Ndec_pl As String, ByVal dsx As Boolean) As String
Dim Td$, dwow$, Td1$
On Error GoTo 1
If co = 0 Then GoTo 1
If NCur = "" Then Ndec = ""
Td = Format(Round(CCur(dNum - Int(dNum)), co), "0." & String(co, "0"))
If Td = 0 Or Td = 1 Then Td1 = "": GoTo 1
If Int(dNum) Then dwow = wow
If Len(Ndec) Then
    Ndec = " " & Ndec
    Td1 = Td * CVar("1" & String(co, "0"))
    If Len(Ndec_pl) And co < 4 Then Td1 = dwow & kh_nText(Format(Td1, "000"), Ndec & "-" & Ndec_pl, 1 + CInt(dsx), 1, 0): GoTo 1
Else
    Ndec = " " & NCur: Td1 = Td
End If
Td1 = dwow & " " & Chr(40) & Td1 & Chr(41) & Ndec
1: kh_dText = Td1
End Function

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

Option Explicit

'========================================================"

' بسم الله الرحمن الرحيم "

' تم تحميل هذا الكود من الرابط التالي

' http://www.officena.net/ib/topic/39447-%D8%AF%D8%A7%D9%84%D8%A9-%D8%AA%D9%81%D9%82%D9%8A%D8%B7-%D8%AA%D8%AD%D9%88%D9%8A%D9%84-%D8%A7%D9%84%D8%B1%D9%82%D9%85-%D8%A7%D9%84%D9%89-%D9%86%D8%B5-%D8%A8%D8%A7%D9%84%D8%B9%D8%B1%D8%A8%D9%8A-%D8%B7%D9%88%D9%84-%D8%A7%D9%84%D8%B1%D9%82%D9%85-%D8%BA%D9%8A%D8%B1-%D9%85%D8%AD%D8%AF%D9%88%D8%AF/

' الكود من كتابة السيد عبد الله باقشير بتاريخ 27/11/2011

' تم التعديل على اسم الكود مع القيم الافتراضية للتتناسب مع العملة السعودية

' كذلك تم تعديل ترتيب مدخلات الدالة لسهولة الحفظ للمستخدم النهائي

' تم التعديل من قبل حسين بلال بتاريخ 22/2/2016

' husseinb[at]viaexcel.com

' www.viaexcel.com

' CurrText

'========================================================"

' (دالة تحويل الرقم الى نص باللغة العربية (تفقيط "

' kh_TextNum "

'========================================================"

'Num الرقم "

'========================================================"

'Sex جنس العملة "

' FALSE ( أو فارغ او صفر مذكر ) "

' TRUE ( أو اي رقم غير الصفر مؤنث ) "

'========================================================"

'NCurr_Si اسم العملة الرئيسية مفرد "

'NCurr_Pl اسم العملة الرئيسية جمع "

'NCurrDec_Si اسم العملة الكسرية "

'Decimal_Count طول الكسر افتراضـياً : بدون اظهار الكسر "

'========================================================"

' : للدلالة على تفقيط الكسر عين التالي "

'NCurrDec_pl اسم العملة الكسرية جمع "

'dSex جنس عملة الكسر "

' FALSE ( أو فارغ او صفر مذكر ) "

' TRUE ( أو اي رقم غير الصفر مؤنث ) "

'========================================================"

'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"

' ملاحظات

' (اولاً : اذا اسم العملة ينتهي بالتاء المربوطة

' يجب ان يكتب كذلك وليس بالهاء

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

' ثانياً : العملة الافتراضية هي العملة السعودية

' وجنس العملة والكسر مؤنث

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

'("" ثالثاً : امكانية إضافة كلمة بداية ونهاية النص (فارغة

Private Const MyBegTx As String = ""

Private Const MyEndTx As String = " فقط لاغير"

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

' MyTNum رابعا : يمكنك التغيير (اضافة,حذف,تحرير) في الثابت

' للفئات الصفرية للرقم ادناه

Private Const MyTNum As String = "ألف-آلاف/مليون-ملايين/مليار-مليارات/بليون-بلايين/بليار-بليارات/ترليون-ترليونات/تريليار-تريليارات/كدرليون-كدرليونات"

'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"

'==============================================================================================================================================="

Private Const wow As String * 2 = " و"

'==============================================================================================================================================="

Function CurrText(Num As String, _

Optional Sex As Boolean = True, _

Optional NCurr_Si As String = "ريال", _

Optional NCurr_Pl As String = "ريالات", _

Optional dSex As Boolean = True, _

Optional NCurrDec_Si As String = "هللة", _

Optional NCurrDec_Pl As String = "هللات", _

Optional Decimal_Count As Byte = 2) _

As String

'======================================

Dim Spp, zt

Dim i%, ii%, pr%

Dim MyMid$, nCurr$, Txt$, Txt1$, Txt2$

'======================================

If Not IsNumeric(Num) Then GoTo kh_Exit

If Num = 0 Then Txt = MyBegTx & "صفر " & NCurr_Si: GoTo kh_Exit

'======================================

Spp = Split("/" & MyTNum, "/")

ii = UBound(Spp)

If Num < 0 Then Num = Abs(Num)

'======================================

If Val(Num) > Val(String((ii + 1) * 3, "9") & ".999") Then GoTo kh_Exit

'======================================

nCurr = NCurr_Si & "-" & IIf(NCurr_Pl = "", NCurr_Si, IIf(NCurr_Si = "", "", NCurr_Pl))

'======================================

Txt1 = Format(Num, String((ii + 1) * 3, "0") & ".000")

For i = 0 To ii

MyMid = Mid(Txt1, (i * 3) + 1, 3)

If MyMid Then

zt = Mid(Txt1, (i * 3) + 4, Len(Txt1))

zt = IIf(ii - i, Int(zt), 1)

Txt2 = IIf(ii - i, Trim(Spp(ii - i)), nCurr)

pr = 1 + IIf(ii - i, 1, CInt(Sex))

Txt = Txt & IIf(Len(Txt), wow, "") & kh_nText(MyMid, Txt2, pr, zt, CBool(NCurr_Si <> ""))

End If

If i = ii Then If MyMid = 0 Then Txt = Txt & IIf(Len(Txt), " " & NCurr_Si, IIf(Decimal_Count = 0, "صفر", ""))

'======================================

Txt = MyBegTx & Txt & kh_dText(Num, NCurr_Si, Trim(NCurrDec_Si), Decimal_Count, Trim(NCurrDec_Pl), dSex) & MyEndTx

'======================================

kh_Exit:

CurrText = Trim(Txt)

End Function

' معالجة العدد من 1 الى 999 لكل فئات الرقم

Private Function kh_nText(ByVal iNum As String, ByVal oMm As String, ByVal ibs As Integer, ByVal Z As Boolean, ByVal tCu As Boolean) As String

Dim Sp

Dim Num1%, Num2%, Num3%

Dim oM$, S$, S1$, nT$, nT0$, nT1$, nT2$

'======================================

Sp = Split("واحد,إحدى,اثنتان,ثلاث,أربع,خمس,ست,سبع,ثمان,تسع,عشر,إحدى ,اثنتا ", ",")

'======================================

If ibs Then S = "ة": Sp(1) = Sp(0): Sp(2) = "اثنان": Sp(11) = "أحد ": Sp(12) = "اثنا " Else S1 = "ة"

oM = Trim(Split(oMm, "-")(0))

'======================================

Num1 = Left(iNum, 1)

Num2 = Right(iNum, 2)

Select Case Num1

Case 1: nT0 = "مائة"

Case 2: nT0 = "مائتا" & IIf(ibs = 2, IIf(Num2 < 3, "", "ن"), IIf(Num2 = 0 And oM <> "", "", "ن"))

Case 3 To 9: nT0 = Sp(Num1) & "مائة"

End Select

'=========================================

Num1 = Right(iNum, 2)

Select Case Num1

Case 1, 2: If nT0 <> "" Then If ibs = 2 Then nT0 = nT0 & " " & oM

Case 11 To 99: If oM <> "" Then If ibs Then If Z Then oM = oM & "اً"

End Select

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

Select Case Num1

Case 1

nT = IIf(oM = "", Sp(0) & S1, oM)

oM = IIf(ibs <> 2 And oM <> "", Sp(0) & S1, "")

Case 2

nT = IIf(oM = "", Sp(Num1), Replace(oM, "ة", "ت") & IIf(Z = 0 And ibs = 2 And tCu, "ا", "ان"))

oM = IIf(ibs <> 2 And oM <> "", Sp(Num1), "")

Case 3 To 10

oM = Trim(Split(oMm, "-")(1))

nT = Sp(Num1) & S

Case 11, 12

nT = Sp(Num1) & Sp(10) & S1

Case 13 To 19

nT = Sp(Num1 - 10) & S & " " & Sp(10) & S1

Case 20 To 99

Num2 = Right(Num1, 1)

Num3 = Left(Num1, 1)

If Num3 = 2 Then nT1 = "عشرون" Else nT1 = Sp(Num3) & "ون"

nT2 = Sp(Num2) & IIf(Num2 > 2, S, "") & wow & nT1

If Num2 = 0 Then nT2 = nT1

nT = nT2

End Select

'======================================

S = IIf(nT = "" Or iNum < 100, "", wow)

nT = Replace(nT, Sp(8) & "ة", Sp(8) & "ية")

kh_nText = Trim(nT0 & S & nT & " " & oM)

'======================================

End Function

' معالجة الكسر

Private Function kh_dText(ByVal dNum As String, ByVal NCur As String, ByVal Ndec As String, ByVal co As Byte, ByVal Ndec_pl As String, ByVal dsx As Boolean) As String

Dim Td$, dwow$, Td1$

On Error GoTo 1

If co = 0 Then GoTo 1

If NCur = "" Then Ndec = ""

Td = Format(Round(CCur(dNum - Int(dNum)), co), "0." & String(co, "0"))

If Td = 0 Or Td = 1 Then Td1 = "": GoTo 1

If Int(dNum) Then dwow = wow

If Len(Ndec) Then

Ndec = " " & Ndec

Td1 = Td * CVar("1" & String(co, "0"))

If Len(Ndec_pl) And co < 4 Then Td1 = dwow & kh_nText(Format(Td1, "000"), Ndec & "-" & Ndec_pl, 1 + CInt(dsx), 1, 0): GoTo 1

Else

Ndec = " " & NCur: Td1 = Td

End If

Td1 = dwow & " " & Chr(40) & Td1 & Chr(41) & Ndec

1: kh_dText = Td1

End Function

ملاحظات على عمل كود التفقيط للغة العربية:

بعد اضافة الكود الى موديول Module في محرر الفجوال بيزك لديك VBA Editor (او بعد تحميل ملف المثال وفتحه), سيمكنك استخدام كود التفقيط المقترح من خلال ادراجه (اضافته) كدالة ضمن ورقة العمل.

بعض اكواد VBA يكون عملها (كهذا الكود) من خلال انشاء دالة مخصّصة جديدة Function يرمز لها بـ UDF والتي هي اختصار لـ User Defined Formula.

وبالتالي, كل ماعليك فعله هو تحديد المكان الذي تريد اظهار نتيجة كود التفقيط فيه ثم اتبع خطوات ادراج معادلة في اكسل Excel,

لاحظ أننا حددنا مجموعة المعادلات User Defined لنتمكن من اظهار هذه المعادلة المخصّصة. سيُظهر لنا اكسل Excel قائمة بكل الـ UDF المتاحة لنا, نختار معادلة كودنا المسماة CurrText (المشتقة من Currency Text)

ومن ثم تقوم بادخال بيانات المعادلة حسب ماسيتم توضيحه لاحقاً, ثم موافق.

مدخلات كود التفقيط للغة العربية:

معادلة كود التفقيط المقترحة تحتاج كحد ادنى لتحديد قيمة المبلغ المراد تفقيطه سواءاً بكتابته بشكل مباشر في متن (نص) المعادلة كما في المثال رقم 5 اعلاه أو من خلال تحديد خليّة المبلغ كما في المثال الثالث والرابع اعلاه. في هذه الحالة, سيتم تطبيق العملة السعودية (ريال / هللة) على النتيجة افتراضياً الا في حال قمت بتعديل القيمة الافتراضية للمعادلة لتناسب احتياجاتك (سيتم شرحه لاحقاً). كذلك يأخذ الكود بعين الاعتبار صيغة التذكير والتأنيث للمبلغ كأن نقول “اثنا عشر” او “اثنتا عشرة” بما يتناسب مع متطلبات المستخدم النهائي. قمت بتأنيث نتيجة المعادلة افتراضياً لكن يمكنك دائماً تغييرها خلال ادراج الدالة او بتغيير القيمة الافتراضية داخل الكود نفسه (سيتم شرحها لاحقاً)
باقي مدخلات المعادلة حسب الرسم التوضيحي اعلاه هي كالتالي,
- جنس العملة: اختياريّة, صفر او فارغة >> مذكر, اي رقم اخر >> مؤنث
- اسم العملة الرئيسية مفرد. اختياريّة, لاحظ انك يجب ان تحيطها دائماً باشارتي قتباس “”
- اسم العملة الرئيسية جمع. اختياريّة, لاحظ انك يجب ان تحيطها دائماً باشارتي قتباس “”
- جنس الجزء العُشري من الرقم (الكسر). اختياريّة, صفر او فارغة >> مذكر, اي رقم اخر >> مؤنث
- اسم العملة للجزء العُشري مفرد. اختياريّة, لاحظ انك يجب ان تحيطها دائماً باشارتي قتباس “”
- اسم العملة للجزء العُشري جمع. اختياريّة, لاحظ انك يجب ان تحيطها دائماً باشارتي قتباس “”
- عدد الخانات العشرية المراد قرائتها. اختياريّة.
الكود يضيف العبارة ” فقط لا غير” افتراضيّاً بعد المبلغ. يمكنك التعديل عليها (صيغةً ومكاناً) من داخل الكود كما سنرى لاحقاً.
في حالة كان اسم العملة ينتهي بتاء مربوطة, يجب كتابةً اسمها بتاء مربوطة وليس هاء. مثال, هللة وليس هلله لتجنب الاخطاء الاملائيّة.
في المثالين الأول والثاني اعلاه, قمت بادخال القيم المتناسبة مع العملة المصريّة لكنني غيرت جنس العملة لاظهار الفرق.

كيفية التعديل على القيم الافتراضية لكود التفقيط:

يمكنك تغيير بعض او جميع القيم الافتراضية لكود التفقيط المقترح لتناسب احتياجاتك كالتالي, بعد نسخ الكود الى محرر الفيجوال بيزك – VBA Editor لديك, يمكنك تعديل القيم حسب التالي,

0. اسم الكود في حال اردت تغييره.

اي نص تريد كتابته قبل القيمة المكتوبة. مثلاً “فقط ” (فقط مائة وخمسون….). يجب اضافة فراغ بعد العبارة التي قد ترغب باضافتها.
اي نص تريد كتابته بعد القيمة المكتوبة. مثلاً ” فقط لا غير” (مائة وخمسون ريال فقط لا غير). يجب اضافة فراغ قبل العبارة التي قد ترغب باضافتها.
هذا مكان المبلغ. لايمكنك التعديل هنا.
جنس العملة, False >> مذكر, True >> مؤنث.
اسم العملة الرئيسية مفرد. لاحظ انك يجب ان تحيطها دائماً باشارتي قتباس “”
اسم العملة الرئيسية جمع. لاحظ انك يجب ان تحيطها دائماً باشارتي قتباس “”
جنس الجزء العُشري من الرقم (الكسر). False >> مذكر, True >> مؤنث
اسم العملة للجزء العُشري مفرد. لاحظ انك يجب ان تحيطها دائماً باشارتي قتباس “”
اسم العملة للجزء العُشري جمع. لاحظ انك يجب ان تحيطها دائماً باشارتي قتباس “”
عدد الخانات العشرية المراد قرائتها. اختياريّة.

يجب التبنيه اخيراً انه وفي حالة اضفت هذه المعادلة داخل ملف العمل الذي يحوي الكود, ستظهر لك المعادلة كما هي مكتوبة اعلاه. اما لو حفظت الكود في ملف عمل آخر ومن ثم حاولت استخدام هذه المعادلة (يجب ان تكون ورقة العمل المذكورة مفتوحة الا في حال كان الكود محفوظاً في الملف الشخصي Personal, لمزيد من المعلومات حول هذه النقطة, راجع الروابط اسفل المقالة) فإنك ستحصل على المعادلة مسبوقة باسم ملف العمل الذي يحوي الكود. لا مشكلة اذا ان النتيجة ستكون هي ذاتها.

للتوضيح, في حال كنت تتسائل مثلي عن معنى كلمة تفقيط. فاعلم انها مشتقة من كلمة فَقَط وفعل فَقَّط والتي تعني (مثلاً فقّط الحساب) ختمه بكلمة « فقط » مع تعيين مقداره خوفا من التزوير

روابط مهمّة:

مصدر الكود
اضافة تبويب المطور Developer
حفظ الأكواد في ملف الماكرو الشخصي
يمكن انشاء اختصار وصول لادراج هذه الدالة مع المدخلات المناسبة لنا كما هو مشروح في هذه المقالة.
مصدر معنى كلمة “تفقيط”

أخيراً ملف المثال المذكور في المقالة.

عن Hussein.B

مؤسس ومدير موقع viaexcel.com, اعمل في مجال الإئتمان, مهتم بمواضيع التدريب وتطوير الذات بالإضافة لحبي الشديد لبرنامج اكسل.

42 تعليقات

Mohsen Alyafei
20 يونيو,2019 في 11:47 م

أول سطر في الدالة يجب تعديله من

Optional Sex As Boolean = True, _

الى

Optional Sex As Boolean = False, _

وذلك لأنه في حال عدم ادخال أي نص افتراضي فأن العملة تكون تلقائيا “الريال”. والريال جنسه مذكر وليس مؤنث

حاليا ناتج (CurrText(2 هو:
ريالان اثنتان فقط لاغير

رد
الصقر
14 أبريل,2019 في 12:26 م

عم انسخ الرابط ولكن بدلا من التفقيط بالعربية عم يطلع عندي اشارات استفهام وكأن اللغة غير مفهومة في هذه الحالة ما العمل

رد
أبو علي طويلة
14 يناير,2019 في 1:12 ص

شكرا شكرا
بارك الله بكم ولكم
عمل مميز مأجورين مجبورين ان شاء الله

رد
علاء الشريف
28 أكتوبر,2018 في 9:04 م

مشكور استاذى الكريم
عندى مشكلة فى دالة التفقيط الكتابة ليست باللغة العربية فماذا افعل
افادكم الله

رد
Ayman imam
8 سبتمبر,2018 في 11:02 م

Case 2
oM = IIf(oM = “”, Sp(Num1), Replace(oM, “ة”, “ة”) & IIf(Z = 0 And ibs = 2 And tCu, “ان”, “ان”))
nT = IIf(ibs 2 And oM “”, Sp(Num1), “”)
أرجو الحل
عدم ربط /ان/ بالليرة أو لاغير إن أمكن المساعدة
فقط : إثنان ليرة سورية لاغيران
ولكن بدون حذفها لأن ذلك سوف يؤثر على مبالغ أخرى مثلا 2200000 سوف يكتبها مليون بدلاً من مليونان
ولكم الشكر

رد
Ayman imam
8 سبتمبر,2018 في 10:28 م

أخي الكريم جزاك الله كل خير ووفقك الله

إذا تكرمت أريد التعديل لحل هذه المشكلة

فقط : إثنان ليرة سورية لاغيران

حتى لاتظهر (ان) أخر الجملة بعد (لاغير)

ولك جزيل الشكر

رد
Awwad
26 أكتوبر,2017 في 11:55 م

احسنت
شرح وافي ومنظم

رد
- Hussein.B
  27 أكتوبر,2017 في 11:11 م
  
  شكراً لمرورك الطيب.
  
  رد
حاتم حريزي
21 أكتوبر,2017 في 10:24 م

السلام عليكم
انا اخذت الدالة وضفتها فى الاكسل لكنها لا تعمل اذا ذاد العدد 999 فما السبب افيدونا جزاكم الله خيرا

رد
- Hussein.B
  22 أكتوبر,2017 في 8:27 ص
  
  السلام عليكم. الكود شغال مع المبالغ الكبيرة. ممكن المشكلة لديك بنسخة اكسل. لم اجد حل لهكذا مشكلة للأسف.
  
  رد
حازم الصواف
3 أكتوبر,2017 في 8:20 ص

ياخي ممكن لوسمحت تعديل نسخه الي تفقيط الساعه اي 11:45ص تصبح (اساعه الحاديه عشر وخمسه واربعون دقيقه صباحا)
ولك كل الشكر

رد
- Hussein.B
  9 أكتوبر,2017 في 3:44 م
  
  سأبحث لك عن هكذا كود.
  
  رد
لينة مصطفى
30 سبتمبر,2017 في 5:46 م

السلام عليكم

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

ارجو ان تساعدني

رد
- Hussein.B
  1 أكتوبر,2017 في 1:30 م
  
  اهلاً لينة, وعليكم السلام. موضوع طريقة كتابة الأكواد موضوع معقد كثيراً كون هذه الدالة عبارة عن كود برمجي مكتوب بلغة الفيجوال بيزك ضمن بيئة اكسل وبالتالي, لتعلم كتابة هكذت كود, عليكي بتعلم لغة البرمجة VBA.
  
  الآن, الجميل في الكود اعلاه أن مصممه جعله مرن ليتم تعديل مخرجاته الرئيسية حسب حاجة المستخدم من نوع العملة, تذكيرها أو تأنيثها, مكان كتابة اسم العملة قبل او بعد المبلغ وهو ماشرحته اعلاه. باقي الأكواد, قد تجدينها مغلقة من هذه الناحية وهو السبب الذي جعنلي اطرح هذا الحل كونه شامل ويغطي احتياجات الجميع حسب رأيي.
  
  رد
علي الحوصلي
22 سبتمبر,2017 في 9:35 م

1قمت بنسخ الكود
2 – فتحت الاكسل وظغطت على زر alt+f11 — وبعدها من قائمة insert اخترت module
3 – الصقت الكود ثم من قائمة fail رجعت للاكسل وبدها اخترت الدالة واشتغلت معي تمام ولكن حاولت حفظ الملف وكانت تظهر لي رسالة كانها تحذيرية

احاول الخروج وعند الدخول مرة اخرى تظهر بشكل خطأ

السؤال
ماهي الطريقة التي احفظ بها المصنف وعند فتحة مرة اخرى تشتغل طبيعي

هل للخيارات التي تظهر تحت اسم المصنف علاقة
مثل الحفظ بتنسيق pdf….الخ

اتمنا اكون قد وصلت استفساري بطريقة مفهومة

رد
علي الحوصلي
13 سبتمبر,2017 في 9:16 م

السلام عليكم
تحية طيبة وبعد
مشكورين على هذا العطاء نسأل الله لكم الاجر في ذلك

استفسار
بعد عمل المعادلات
كيف احفظ المصنف
عندما احفظة لايعمل مرة اخرى بعد فتحة

شاكرين لكم التعاون
وجزاكم الله خير

رد
- Hussein.B
  13 سبتمبر,2017 في 9:50 م
  
  وعليكم السلام علي. هل لك ان تشرح لي الخطوا اللي تنفذها بالتفصيل؟
  
  رد
  - علي الحوصلي
    22 سبتمبر,2017 في 9:24 م
    
    1قمت بنسخ الكود
    2 – فتحت الاكسل وظغطت على زر alt+f11 — وبعدها من قائمة insert اخترت module
    3 – الصقت الكود ثم من قائمة fail رجعت للاكسل وبدها اخترت الدالة واشتغلت معي تمام ولكن حاولت حفظ الملف وكانت تظهر لي رسالة كانها تحذيرية
    
    احاول الخروج وعند الدخول مرة اخرى تظهر بشكل خطأ
    
    السؤال
    ماهي الطريقة التي احفظ بها المصنف وعند فتحة مرة اخرى تشتغل طبيعي
    
    هل للخيارات التي تظهر تحت اسم المصنف علاقة
    مثل الحفظ بتنسيق pdf….الخ
    
    اتمنا اكون قد وصلت استفساري بطريقة مفهومة
    
    رد
    - علي الحوصلي
      22 سبتمبر,2017 في 9:32 م
      
      هل استطيع التواصل معكم
      انا اشتغل محاسب في اعمال عقارات واتمنى اشتغل بنظام يسهل لي المهمة من ناحية سندات الصرف والقبص وحسابات العمال واسعار المواد وكمياتها وحسابات المساهمين والارباح والمصروفات …الخ
      
      رد
      - Hussein.B
        24 سبتمبر,2017 في 10:28 م
        
        مرحباً بك بأي وقت أخ علي لكن للأسف لا استطيع افادتك بموضوع البرنامج كحل لعملك. ممكن اني افيدك بأي مشكلة ضمن اكسل ممكن تواجهك واحاول الاقيلك حل الها. يمكنك التواصل معي من خلال صفحة الموقع على فيسبوك أو صفحة تواصل معنا.
        
        رد
    - Hussein.B
      24 سبتمبر,2017 في 10:27 م
      
      مرحباً علي. راجع الموضوع التالي واللي رح يفيدك بطريقة حفظ الكود للاستخدام اللاحق.
      
      https://goo.gl/moUmgE
      
      رد
باسم القادري
26 أبريل,2017 في 4:45 م

اشكركم
ولكن لماذا لا يمكن كتابة العدد اكبر من 999
وكيف يمكن ان اكبر مدى الدالة

رد
- Hussein.B
  26 أبريل,2017 في 11:30 م
  
  مرحباً باسم, الدالة تقبل ارقام كبيرة جداً وهي غير محدودة بالرقم 999. هذا مثال جربته قبل كتابة ردي,
  
  مليار ومائتان وسبعة وثلاثون مليوناً وخمسمائة وواحد وعشرون ألفاً وثلاثمائة وأربع وخمسون جنيه واثنتا عشرة قرش فقط لاغير
  
  رد
محمود محمد احمد محمد
21 يناير,2017 في 9:18 ص

السلام عليكم
لايوجد كود تفقيط لثلاث خانات قبل الفاصلة
مثال
1.999
دينار و تسعمئة و تسعة و تسعون فلس

رد
- Hussein.B
  25 يناير,2017 في 7:46 ص
  
  اهلاً محمود. وعليكم السلام. ماجربت الكود على هيك رقم للأمانة. عندي مشكلة بالجهاز مع اللغة العربية, رح احلها واردلك خبر لاحقاً ان شاء الله.
  
  رد
domty
11 يناير,2017 في 9:18 م

ارجو الحصول على كود تفقيط درجات الطلاب مثال مائة واربعة وخمسون درجة ونصف الدرجة فقط

رد
- Hussein.B
  12 يناير,2017 في 8:27 ص
  
  مرحباً أخي. يمكنك استخدام نفس الكود في هذه المقالة مع تغيير اسم العملة والكسر الى درجة, واسم الجمع للعملة والكسر الى درجات.
  
  رد
mohamed m
27 ديسمبر,2016 في 3:38 م

ا/ حسين جزالك الله خيرا علي ما قدمت
ولكن بعد ما نزلت الكود وبحثت عن الدالة وجدتها وعند تنفيذها ظهرت هذه النتيجه
؟؟؟؟؟؟ ؟؟؟؟؟؟؟ جنيه ؟؟؟؟؟؟؟؟ ؟؟؟؟؟؟
ما معني هذا ؟ وكيف يتم علاجه
ولكم كل الشكر والاحترام
” اتمني الرد حالا لانني اقوم بتنفيذها الان ومحتاجها ضروري “

رد
- Hussein.B
  27 ديسمبر,2016 في 5:29 م
  
  مرحبا اخ محمد. المشكلة هنا باعدادات الجهاز لديك. غير اعدادات الجهاز من لوحة التحكم ليقرأ اللفات غير المفهومة كلغة عربية.
  
  رد
  - mohamed m
    28 ديسمبر,2016 في 1:33 م
    
    ا/ الفاضل قمت بتغيير اعدادت اللغة الي العربيه ” مصر ” لأنها كانت العربية ” السعودية ”
    ولكن تبقي النتيجه كما هي
    المشكلة تكمن في الكود نفسه يافندم لما اخذت نسخة من الكود من جوجل ولصقتها في الموديل
    ظهر عندي كله بنفس الشكل ؟؟؟؟؟؟؟؟؟ ؟؟؟؟؟؟؟؟؟ ؟؟؟؟؟؟؟؟
    ولما غيرت الاعدادات لم يتغير اي شئ
    هل يوجد ملف للكود انزله افضل من النسخ من جوجل ولا حضرتك شايف ايه الحل ؟
    
    رد
    - Hussein.B
      29 ديسمبر,2016 في 8:26 ص
      
      المشكلة التي طرحت هي مشكلة اعدادت جهاز وليس مشكلة كود. بكل الأحوال, يوجد ملف مرفق في الموضوع يمكنك تحميله وتشغيل الكود من خلاله لكن ستجد نفس المشكلة.
      
      راجع الموضوع التالي وغيره كثير على النت بنفس الخصوص,
      http://stackoverflow.com/questions/18868029/arabic-characters-dont-show-in-excel-vba-code
      
      رد
ahmed
11 يوليو,2016 في 6:49 م

1-عند كتابة 2000 تظهر فقط ألفا جنيهاً مصرياً لاغير والمفروض ان تظهر فقط ألفان جنيهاً مصرياً لاغير مضافا اليها (ن) فهل من حل
2- عند كتابة 17002 تظهر فقط سبعة عشر ألفً وجنيهاً مصرياً اثنان لاغير والمفروض ان تظهر فقط سبعة عشر ألفً ولثنان جنيهاً مصرياً لاغير

رد
- Hussein.B
  12 يوليو,2016 في 8:20 م
  
  جرب عكس جنس العملة في مدخلات المعادلة.
  
  رد
  - ahmed
    13 يوليو,2016 في 1:47 م
    
    نفس الخطأ حتى بعد تغيير جنس العملة
    
    وكذلك 2222 تظهر فقط ألف ومائتان واثنتان وعشرون جنيهاً مصرياً لاغير
    
    والصح هو فقط ألفان ومائتان واثنتان وعشرون جنيهاً مصرياً لاغير
    وهذا خطأ كارثى عند طباعة الشيكات
    
    رد
    - Hussein.B
      17 يوليو,2016 في 11:13 ص
      
      أخ أحمد, اصعب مافي اللغة العربية هو التذكير والتأنيث ومايتبع هذا الموضوع من قواعد لغوية واملائية. اعتقد أن الكود المقترح اعلاه هو من افضل الأكواد التي استطاع كاتبه سد هذه الفجوة. ربما لم يقم بذلك على اتم وجه “حسب رأيك” من ناحية ألفا أم ألفان (رغم قناعتي بأن ألفا هي أصح من ألفان) لكنه قام بعمل جيد لا اعتقد انك ستجد أفضل منه في المواقع العربية. اما بخصوص المبلغ 2222 فقد قمت بتجربته وقد اعطاني العبارة الصحيحية “ألفان ومائتان واثنتان وعشرون ريال فقط لاغير”
      
      رد
محمود أمين
8 مايو,2016 في 1:01 ص

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

عندي الأوفيس باللغة العربية – وحاولت تبويب كود ( المطور ) ولكن لم أستطيع – أرجو مساعدتي في ذلك – وايضا شرح وافي لتفعيل دالة التفقيط بالانجليزي عي هذه النسخة – العملة ريال سعودي

وشكرا

رد
- Hussein.B
  8 مايو,2016 في 2:41 ص
  
  وعليكم السلام, حياك الله اخ محمود. ل
  
  اضافة تبويب المطور, اتبع الخطوات المذكورة في المقالة التالية,
  http://goo.gl/fDjCt9
  
  اما بخصوص دالة التفقيط في اللغة الانكليزية, فيمكنك مراجعة الموضوع التالي,
  http://goo.gl/WMpm8W
  
  انا جاهز لا مساعدة قد تحتاجها.
  
  رد
whosaini654
16 أبريل,2016 في 9:25 ص

هذا عمل رائع بارك الله فيك حيث كنت ايحث عن هذه الدالة مدة طويلة وحاولت عملها من قبل من عدة مواقع لكنها لم تظبط معي ولكن لدى سؤال : ألا يمكن الاشارة الي مرجع الخلية في في شاشة :ادخال بيات المعادلة” في خنة num بدلا من ادخال الرقم المراد تفقيطه ثم يمكن نسخ الخلية الى اسفل في ملف الاكسل . انا جربت هذه الطريقة لكن للاسف النتيجة تطلع خطأ هكذا
25 خمس وعشرون ريال
311 ثلاثمائة وإحدى عشرة ريال
10266 #VALUE!
56994 #VALUE!

هل يوجد حل لهذه المشكلة ؟؟؟؟؟ مرة اخرى لك جزيل الشكر

رد
- Hussein.B
  16 أبريل,2016 في 6:38 م
  
  حياك الله اخي الكريم. اكسل يعامل هذه الدالة كانها دالة افتراضية وبالتالية ماطلبته متاح افتراضيا. هل لك ان ترفع ملف العمل لارى سبب الخطأ الذي تحصل عليه؟
  
  رد
  - whosaini654
    21 أبريل,2016 في 10:40 ص
    
    اشكرك اخي HUSSEIN.B لسرعة استجابتك وآسف لتأخري في الرد بس ما اعرف من فين وكيف ارفع الملف لايوجد هنا ايقونة للرفع . وبعدين لو سمحت سؤال : من اين يبدا الكود من :
    Private Const wow As String * 2 = ” و أم من :Private Const wow As String * 2 = ”
    وبارك الله فيك
    
    رد
    - Hussein.B
      21 أبريل,2016 في 10:46 ص
      
      حياك الله عزيزي. بخصوص التحميل, يمكنك تحميل المثال على اي موقع تحميل ملفات مثل 4shared.com ووصع الرابط هنا.
      
      اما بخصوص الكود فهو يبدأ من أول كلمة,
      Option Explicit
      
      في صندوق الكود, يوجد ايقونة في الشريط العلوي للصندوق تحوي زر النسخ لتسهيل عملية النسخ عليك او يمكنك تحميل الملف المثال من آخر المقالة ومن ثم نسخ الكود منه. بانتظار ارسالك الملف لارى المشكلة.
      
      رد