هاشم طه

الأخ حيدر فلاح السلام عليكم ورحمة الله وبركاته مرفق ملف وورد 2019 ارجو ان يعمل معك وممكن به ماكرو رقم 1 او انسخ الكود التالي وضعه في موديل واضغط على ماكرو وسيعمل في الجدول باذن الله وبالطبع عمل التفقيط في كل خلية في جدول وورد غير مجدي فالافضل عمل التفقيط في نهاية الفواتير والاقضل عملها باكسيل Private Const MyBegTx As String = " فقط " Private Const MyEndTx As String = " لا غير" ' ----------------------- Private Const MyTNum As String = "ألف-آلاف/مليون-ملايين/مليار-مليارات/بليون-بلايين/بليار-بليارات/ترليون-ترليونات/تريليار-تريليارات/كدرليون-كدرليونات" Private Const wow As String * 2 = " و" Function CurrText(Num As String, _ Optional Sex As Boolean = False, _ Optional NCurr_Si As String = "دينار", _ Optional NCurr_Pl As String = "دنانير", _ Optional dSex As Boolean = False, _ Optional NCurrDec_Si As String = "فلس", _ Optional NCurrDec_Pl As String = "فلوس", _ Optional Decimal_Count As Byte = 3) _ 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 MsgBox "لطفاً أدخل رقم...ليتم التحويل . ", vbCritical + vbMsgBoxRight + vbMsgBoxRtlReading, "رسالة هاشم " Selection.Text = "" GoTo kh_Exit End If '====================================== 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 Sub Macro1() lCursorMovement = Options.CursorMovement If Options.CursorMovement = wdCursorMovementVisual Then Options.CursorMovement = wdCursorMovementLogical lRange = Selection.MoveWhile(cset:="0123456789.,،", Count:=wdBackward) lParaAlignment = Selection.ParagraphFormat.Alignment Selection.ParagraphFormat.ReadingOrder = RtlPara Selection.ParagraphFormat.Alignment = lParaAlignment If lRange <> 0 Then Selection.MoveRight Unit:=wdCharacter, Count:=-lRange, Extend:=wdExtend Selection.TypeText CurrText(Selection) End If End Sub n2w.docm

السلام عليكم ورحمة الله وبركاته حدد العمود كاملا من تنسيق الخلية الفئة - تاريخ - نوع التقويم ميلادي او ميلادي من تبويب محاذاة 1- من اليمين لليسار يجعل الارقام بالعربي 2- من اليسار لليمين يجعل الارقام انجليزي 3- السياق الارقام انجليزي

السلام عليكم ورحمة الله وبركاته ،، كل الشكر للاستاذ/ عبد الله باقشير وأتمنى أن يكون بكامل الصحة فقد تعلمنا منه الكثير من اصول البرمجة وكأنما صيغت له التعليمات البرمجية فقد كان يطوعها كيفما شاء وهذا البرنامج كان قد أسماه كاس العالم 2010 وودت أن أبدل فيد الدول وأسميه كاس العالم 2018 وبنفس توقيعه ، كل الشكر والامتنان له وليسمح لنا في تعديل بعض أعماله ، و الصفحات محمية بدون كلمة سر عد ما كان يحفظه هو بكلمة سر . تحياتي لكم واتمنى أن يعود بالنفع لكم ولتدعوا للاستاذ / خبور خير . http://www.mediafire.com/file/mnnh0p26akx191w/World_Cup_2018.rar

السلام عليكم ورحمة الله وبركاته ،، اخواني الاعزاء عدلت برنامج قديم لكأس العالم كان قد قام برفعه استاذنا ومعلمنا خبير الاكواد و مستشار المعادلات الاستاذ / عبد الله باقشير ( خبور خير ) وله كل الشكر والتقدير وارجو ان يتمتع بوافر الصحة وله كل الشكر والاحترام على ما بذله من جهد وقد تعلمنا منه الكثير جعل الله ما قام به من عمل في ميزان حسناته .

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