نجوم المشاركات

تحية طيبة برنامج حسابات بعد التعديل لن النسخة الاولى كان فيها بعض النواقص وتم اكمالها اسم المستخدم: المدير باسورد:123 محرر الاكواد:251869 الشيت: 251869 تحياتي محمد علي الطيب برنامج محاسبة.rar

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

رابط البرنامج http://www.mediafire.com/download/5wwti6tzj236g7z/eBook+Workshop.msi ودا شرح راجل محترم اللي بيشرح الصراحه وشكرا

السلام عليكم ورحمة الله وبركاته هل تعني أن يكون معرباً كما في المرفق يرجى أن يرضيكم New-Userform-.rar

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

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

اخى عبد العزيز البسكري تسلم ايدك وجزاك الله كل خير ابانا الغالى ابويوسف جزاك الله كل خير

عسى ان يكون المطلوب جرب هذا الكود Sub talween() For x = 1 To Sheets.Count With Sheets(x) ro = .Cells(Rows.Count, "O").End(3).Row .Range("a1:o" & ro).ClearFormats For Each cell In .Range("o1:O" & ro) If IsNumeric(cell) And cell.Value < 0 Then cell.Offset(0, -14).Resize(1, 15).Interior.ColorIndex = 3 End If Next End With Next End Sub

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

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

جرب هذا الملف واضغط اعجبني Num_Of_Words.rar

تسلملي ياغالي ياعم عبد العزيز انت تقدر تعمل كتب بالفيجوال بيسك ابحث وانت تلاقي اما البرنامج دا يعتبر مصمم في حدود وبعدين غطس ايه يامعلم انا مبعرفشي اعوم تقبل فائق احترامي اخي الغالي احمد بارك الله فيك وجزاك كل الخير على دعائك الجميل تقبل خالص تحياتي ياخال الجردل مليان بس النفس ولو فاضي نملاه عشان خاطركم هو الجردل بيسرب شوية بس هنتدارك الموضوع دا ودا برنامج افضل شوية بيدعم ملفات الpdf والورد والفلاش وصور رابط البرنامج http://www.kvisoft.com/download/fbm/kvisoft-fbm-pro-trial.exe سيريال mmm@mail.com 6EDXAIA3AXCORAJR8KDG شرح بالفيديو بردو نفس الراجل المحترم بتاع الشرح اللي فات وشكرااااااااااا اهو دي طرطشة من الجردل

أخي وحبيبي في الله ياسر العربي جزاكم الله خيراً على هذه الهدية القيمة والرائعة أيوا كدا هو دا الدلو .. لما أقول كل يدلي بدلوه .. مش يطلع الدلو فاضي ..كدا الدلو طلع ملياااااااااااااان وفي الجوووووووووووول سأقوم بدراسة الفيديو محاولاً فهم الطريقة بشكل جيد وإذا تعثرت في أمرٍ ما سأقوم بطرح مشاركة جديدة ليستفيد الجميع ألف ألف ألف شكر وربنا يبارك فيك ويزيدك من علمه ... تقبل وافر تقديري واحترامي

السّلام عليكم و رحمة الله و بركاته أبشرْ يا ياسر يا عربي أبشرْ بفضل من الله و رضوان إن شاء الله كل دروسك عبارة عن الغطس في أعماق المحيطات .. و يلزمك غوّاصة للخروج من ذلك ماذا أقول لك .. مادام غطسك فيه متعة و منفعة و فائدة ..إلاّ .. جزاك الله خيرًا و زادها بميزان حسناتك و أغطسكَ الله في أوسع جنّاته بإذن الله فائق إحتراماتي و إعجاباتي

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

لا تنسَ ايضاً حرف الياء المشترك بين الثلاثة (مرتين لكل واحد)

السّلام عليكم و رحمة الله و بركاته أخي الغالي و أستاذي الحبيب ياسر خليل أبو البراء مخلصًا من كل قلبي أبارك هذا الطّرح و الاستفسار ..موضوع فعلاً يستحق المتابعة مع سبق الاصرار و الترصّد أنا عن نفسي كم تمنيت تعلّم هكذا أعمال .. سأتابع معك إن شاء الله أدعو من الإخوة الأكارم فضلاً لا أمرًا من يمكنه المساعدة ألاَّ يبخل علينا بما علّمه الله إياه بارك الله في الجميع مقدّمًا فائق إحتراماتي

ربما يجب استبدال الكود بهذا (من الضروري تجربة الكود على ملف وهمي او نسخة احتياطية قبل ذلك) Sub talween1() For x = 1 To Sheets.Count With Sheets(x) ro = .Cells(Rows.Count, "O").End(3).Row For Each cell In .Range("o1:O" & ro) If IsNumeric(cell) And cell.Value < 0 Then cell.Offset(0, -14).Resize(1, 15).Interior.ColorIndex = 3 Else cell.Offset(0, -14).Resize(1, 15).Interior.ColorIndex = vbBlack End If Next End With Next End Sub

أخي الكريم استبدل الجزء الأخير في الكود في الفورم المسمى Account بالكود عاليه

أخي الكريم أبو خالد يرجى تغيير اسم الظهور للغة العربية إليك حل بالأكواد إثراءً للموضوع Sub Test() Dim I As Long, FirstName As String, FatherName As String, Str As String For I = 2 To Cells(Rows.Count, 1).End(xlUp).Row FirstName = Kh_Names(Cells(I, 1), 1) FatherName = Cells(I, 2) Str = Mid(Cells(I, 1), Len(FirstName) + 1) Cells(I, 4).Value = FirstName & " " & FatherName & Str Next I End Sub Function Kh_Names(FullName As String, ParamArray iNdex1()) As String Dim I As Integer Dim Kh_Split, MyArray, Ar Dim Kh_String As String, SN As String, RE As String On Error GoTo Err_Kh_Names MyArray = Array("عبد ", "أبو ", "ابو ", "آل ", " الله", " الدين", " الإسلام", " الاسلام", " الحق", " النصر", " العهد", " النور", " بالله") SN = Application.WorksheetFunction.Trim(FullName) For Each Ar In MyArray RE = Replace(Ar, " ", "^") SN = Replace(SN, Ar, RE) Next Kh_Split = Split(SN, " ", , vbTextCompare) On Error Resume Next For I = 0 To UBound(iNdex1) Kh_String = Kh_String & " " & Kh_Split(iNdex1(I) - 1) Next On Error GoTo 0 Kh_String = Replace(Trim(Kh_String), "^", " ") Kh_Names = Kh_String Exit Function Err_Kh_Names: Kh_Names = "" End Function تقبل تحياتي

السلام عليكم ورحمة الله إخوتي الكرام أخي الطيب اسماً ومسمىً جزاكم الله خيراً على هذا العمل الماتع والقوائم الرائعة وإلى المزيد بعون الله تعالى أسال الله لنا ولكم التوفيق والسداد والنجاح والفلاح ...آمين والسلام عليكم.

السلام عليكم أخى الفاضل / محمد على بارك الله فيك أخى الفاضل ولكن لى ملاحظة واحدة على المعادلة المستخدمة =IF(OR(B4="غ";C4="غ";D4="غ";E4="غ");"غ";SUM(B4;C4;D4;E4)) حضرتك استخدمت دالة OR لاختبار شرط الغياب وهى تعنى أنه غاب الطالب ولو فى مادة واحدة فقط يعتبر غائب فى المجموع وهذا غير منطقى حيث من المفروض استخدام دالة AND لكى يعتبر الطالب غائب فى المجموع اذا غاب فى جميع المواد وليس مادة واحدة

شوف الملف المرفق لعله طلبك كود تحويل الارقام إلى لغة عربية.rar

برامجك اخي الغالي محمد على الطيب لها طابع ومظهر رائع وقوائم جميلة جزاك الله خيرا ودائما في تقدم وباذن الله نجرب البرنامج تقبل تحياتي

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

السلام عليكم استخدم أخى هذه المعادلة =IF(AND(B4="غ";C4="غ");"غ";SUM(B4:C4)) Book1.rar

السلام عليكم ورحمة الله وبركاته دعوة للتمعن بآيات الله إخوتي الكرام آيتين كريمتين الأولى: أَفَحَسِبْتُمْ أَنَّمَا خَلَقْنَاكُمْ عَبَثًا وَأَنَّكُمْ إِلَيْنَا لَا تُرْجَعُونَ (115) سورة المؤمنون: قوله تعالى : أفحسبتم أنما خلقناكم عبثا وأنكم إلينا لا ترجعون قوله تعالى : أفحسبتم أنما خلقناكم عبثا أي مهملين كما خلقت البهائم لا ثواب لها ولا عقاب عليها ؛ مثل قوله تعالى : أيحسب الإنسان أن يترك سدى يريد كالبهائم مهملا لغير فائدة . قال الترمذي الحكيم أبو عبد الله محمد بن علي : إن الله تعالى خلق الخلق عبيدا ليعبدوه ، فيثيبهم على العبادة ويعاقبهم على تركها ، فإن عبدوه فهم اليوم له عبيد أحرار كرام من رق الدنيا ، ملوك في دار الإسلام ؛ وإن رفضوا العبودية فهم اليوم عبيد أباق سقاط لئام ، وغدا أعداء في السجون بين أطباق النيران . و ( عبثا ) نصب على الحال عند سيبويه وقطرب . وقال أبو عبيدة : هو نصب على المصدر أو لأنه مفعول له . وأنكم إلينا لا ترجعون فتجازون بأعمالكم . قرأ حمزة ، والكسائي ترجعون بفتح التاء وكسر الجيم من الرجوع . الثانية: أَيَحْسَبُ الْإِنسَانُ أَن يُتْرَكَ سُدًى (36)سورة القيامة: قوله تعالى : أيحسب الإنسان أي يظن ابن آدم أن يترك سدى أي أن يخلى مهملا ، فلا يؤمر ولا ينهى ; قاله ابن زيد ومجاهد ، ومنه إبل سدى : ترعى بلا راع . وقيل : أيحسب أن يترك في قبره كذلك أبدا لا يبعث . وقال الشاعر : فأقسم بالله جهد اليمين ما ترك الله شيئا سدى أخوكم أبو يوسف عن موقع(مشروع المصحف الإلكتروني)...

أخي الكريم حمادة جرب التعديل في الجزء الخاص ببدء تشغيل الفورم Private Sub UserForm_Initialize() Dim C As Integer For C = 1 To ContColmn With ورقة1 Me.Controls("xx" & C).Caption = .Cells(1, C).Value End With Next With ورقة1 Me.ComboBox2.AddItem .Cells(1, 1).Value Me.ComboBox2.AddItem .Cells(1, 2).Value Me.ComboBox2.AddItem .Cells(1, 33).Value End With Me.ComboBox2.Style = 2 End Sub تقبل تحياتي

أخي الكريم محمود جرب الكود التالي عله يكون المطلوب ... Private Sub CommandButton1_Click() Dim Coll As New Collection, arrData, arrOut, arrStrSheet, strSheet, arrBlank, arrTemp Dim I As Long, J As Long, K As Long, strKey As String arrStrSheet = Array("المشتروات", "المبيعات") ReDim arrBlank(0 To 4) For K = LBound(arrStrSheet) To UBound(arrStrSheet) With Sheets(arrStrSheet(K)) arrData = .Range("C6:E" & Application.Max(.Cells(.Rows.Count, "C").End(xlUp).Row, .Range("C6").Row)).Value On Error Resume Next For I = 1 To UBound(arrData, 1) strKey = Trim$(arrData(I, 1) & Chr$(2) & arrData(I, 2)) arrTemp = arrBlank arrTemp = Coll(strKey) arrTemp(0) = arrData(I, 1) arrTemp(1) = arrData(I, 2) arrTemp(K + 2) = arrTemp(K + 2) + arrData(I, 3) Coll.Remove strKey Coll.Add Key:=strKey, Item:=arrTemp Next I On Error GoTo 0 End With Next K ReDim arrOut(1 To Coll.Count, 1 To 5) I = 0 For Each arrTemp In Coll I = I + 1 For J = 0 To 3 arrOut(I, J + 1) = arrTemp(J) Next J arrOut(I, 5) = arrOut(I, 3) - arrOut(I, 4) Next arrTemp With Sheets("جرد البضاعة").Range("B5") .CurrentRegion.Offset(1, 1).ClearContents If Coll.Count Then With .Offset(1, 1).Resize(UBound(arrOut, 1), UBound(arrOut, 2)) .Value = arrOut .Sort Key1:=.Columns(1), Order1:=xlAscending, Key2:=.Columns(2), Order2:=xlAscending, Header:=xlNo End With End If End With End Sub وإليك الملف المرفق فيه تطبيق الكود تقبل تحياتي Transfer Purchases & Sales Using Arrays.rar

بارك الله فيك أخي الحبيب عبد العزيز على الهدية القيمة وجزاكم الله خير الجزاء بس يا ريت لو فيه نسخة إنجليزي منه .. تقبل تحياتي

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

هههههههههههههههه اشتغل وربنا محدش يتريق عليا والله انا مش مصدق انى خلصت الشغل ف اقل من دقيقه شغل كان ممكن يقعد معايه اسبوعين مهما اقول من كلام مش هعرف اشكركم على الى عملتوه معايا وربنا انتم ناس محترمه جدااااااااااااااااااا ربنا يجعلو فى ميزان حسناتكم :D

شكرا استاذ محمد مجهود تشكر عليه لك كل الشكر والتقدير

أخى الفاضل / محمد على أجمل وأرق تحياتى لشخصكم الكريم بقى أن يوضح أخونا محمد ماهر صاحب السؤال ماذا يقصد بالضبط ويأخذ بما يريده

السلام عليكم لماذا لا تضع قائمة باسماء الطابعات في النموذج ، ويجب عليه اختيار الطابعه قبل الطباعة؟ هذا الرابط به عدة مرفقات وروابط اخرى ، وفيها الطريقة: http://www.officena.net/ib/topic/49802-اختيار-اسم-الطابعة-عند-طباعة-تقرير/ جعفر

ألف شكر سيّدي القدير محمد علي الطيّب نسخة جد ممتازة بكل صدق .. أعجبتني كثيرا جزاك الله خيرا و زادك من علمه و فضله

وعليكم السلام اعمل حقل في الجدول بإسم Bal ، اذا كان برنامجك على الاكسس 2007 فما فوق ، ففي الجدول حقل من نوع "حقل محسوب" ، تجعل فيه المعادلة التي تريد للحقل Bal ، وهو يحسبها تلقائيا اما الطريقة الاخرى ، ففي النموذج ، وعلى حدث "بعد التحديث" للحقل العدد المطلوب بيعة ، اعمل المعادلة: me.Bal= me.الرصيد - me.العدد والقيمة تلقائيا ستدخل النموذج والجدول جعفر

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

الأخ العزيز كريم بارك الله فيك وجزاك الله كل خير ملف جميل جداً ومتميز .. الأخ الحبيب أحمد الملف الذي أرفقه الأخ كريم عبارة عن موديول تم تصديره ليكون ملف منفصل ، ويتم استيراده بالشكل التالي : روح لمحرر الأكواد ..كليك يمين في نافذة المشروع .. اختار الأمر Import File .. حدد مكان الملف الذي أرفقه الأخ كريم بعد فك ضغطه بالطبع والذي امتداده Bas .. وأخيراً انقر الأمر Open .. ستجد أن الموديول قد أضيف في نافذة المشروع وإليك الكود الموجود بالملف بعد تنسيقه بشكل مناسب (أحب تنسيق الأكواد ليسهل التعامل معها) Private Function ChangeToDigits1(Temp As String) As String If Temp = "0" Then ChangeToDigits1 = "" GoTo Finish End If If Temp = "1" Then ChangeToDigits1 = "واحد" GoTo Finish End If If Temp = "2" Then ChangeToDigits1 = "اثنان" GoTo Finish End If If Temp = "3" Then ChangeToDigits1 = "ثلاثة" GoTo Finish End If If Temp = "4" Then ChangeToDigits1 = "أربعة" GoTo Finish End If If Temp = "5" Then ChangeToDigits1 = "خمسة" GoTo Finish End If If Temp = "6" Then ChangeToDigits1 = "ستة" GoTo Finish End If If Temp = "7" Then ChangeToDigits1 = "سبعة" GoTo Finish End If If Temp = "8" Then ChangeToDigits1 = "ثمانية" GoTo Finish End If If Temp = "9" Then ChangeToDigits1 = "تسعة" GoTo Finish End If Finish: End Function Private Function ChangeToDigits2(Temp As String) As String Dim Digit1 As String Dim Digit2 As String Dim Between As String Digit2 = Left(Temp, 1) Digit1 = Right(Temp, 1) If Digit2 = "1" Then ChangeToDigits2 = "عشر" GoTo Finish End If If Digit2 = "2" Then ChangeToDigits2 = "عشرون" GoTo Finish End If If Digit2 = "3" Then ChangeToDigits2 = "ثلاثون" GoTo Finish End If If Digit2 = "4" Then ChangeToDigits2 = "أربعون" GoTo Finish End If If Digit2 = "5" Then ChangeToDigits2 = "خمسون" GoTo Finish End If If Digit2 = "6" Then ChangeToDigits2 = "ستون" GoTo Finish End If If Digit2 = "7" Then ChangeToDigits2 = "سبعون" GoTo Finish End If If Digit2 = "8" Then ChangeToDigits2 = "ثمانون" GoTo Finish End If If Digit2 = "9" Then ChangeToDigits2 = "تسعون" GoTo Finish End If Finish: If Digit1 = "0" Then Digit1 = "" Between = "" Else If Digit2 = "1" Then Between = " " Digit1 = ChangeToDigits1(Digit1) Else Between = " و " Digit1 = ChangeToDigits1(Digit1) End If End If If Digit2 = "0" Then Between = "" ChangeToDigits2 = Digit1 & Between & ChangeToDigits2 If Temp = "00" Then ChangeToDigits2 = "" If Temp = "11" Then ChangeToDigits2 = "احدى عشر" If Temp = "12" Then ChangeToDigits2 = "اثنا عشر" If Temp = "10" Then ChangeToDigits2 = "عشرة" End Function Private Function ChangeToDigits3(Temp As String) As String Dim Between As String Dim Handred As String Dim First As String Dim Second As String Handred = " مائة" First = ChangeToDigits1(Left(Temp, 1)) Second = ChangeToDigits2(Right(Temp, 2)) If Second <> "" Then Between = " و " Else Between = "" If First = "" Then Between = "" Handred = "" End If If First = "واحد" Then First = "" If First = "اثنان" Then First = "" Handred = "مئتا" End If ChangeToDigits3 = First & Handred & Between & Second If Temp = "000" Then ChangeToDigits3 = "" End Function Private Function ChangeToDigits4(Temp As String) As String Dim Between As String Dim Thousand As String Dim First As String Dim Second As String Thousand = " آلاف" First = ChangeToDigits1(Left(Temp, 1)) Second = ChangeToDigits3(Right(Temp, 3)) If Second <> "" Then Between = " و " Else Between = "" If First = "" Then Between = "" Thousand = "" End If If First = "واحد" Then First = "" Thousand = "الف" End If If First = "اثنان" Then First = "" Thousand = "الفا" End If ChangeToDigits4 = First & Thousand & Between & Second If Temp = "0000" Then ChangeToDigits4 = "" End Function Private Function ChangeToDigits5(Temp As String) As String Dim Between As String Dim Thousand As String Dim First As String Dim Second As String Thousand = " ألف" First = ChangeToDigits2(Left(Temp, 2)) Second = ChangeToDigits3(Right(Temp, 3)) If Second <> "" Then Between = " و " Else Between = "" If First = "" Then Between = "" Thousand = "" End If If First = "واحد" Then First = "" Thousand = "ألف" End If If First = "اثنان" Then First = "" Thousand = "ألفا" End If ChangeToDigits5 = First & Thousand & Between & Second If Temp = "00000" Then ChangeToDigits5 = "" End Function Private Function ChangeToDigits6(Temp As String) As String Dim Between As String Dim Thousand As String Dim First As String Dim Second As String Thousand = " الف" First = ChangeToDigits3(Left(Temp, 3)) Second = ChangeToDigits3(Right(Temp, 3)) If Second <> "" Then Between = " و " Else Between = "" If First = "" Then Between = "" Thousand = "" End If If First = "واحد" Then First = "" Thousand = "ألف" End If If First = "اثنان" Then First = "" Thousand = "ألفا" End If ChangeToDigits6 = First & Thousand & Between & Second If Temp = "000000" Then ChangeToDigits6 = "" End Function Private Function ChangeToDigits7(Temp As String) As String Dim Between As String Dim Million As String Dim First As String Dim Second As String Million = "ملايين" First = ChangeToDigits1(Left(Temp, 1)) Second = ChangeToDigits6(Right(Temp, 6)) If Second <> "" Then Between = " و " Else Between = "" If First = "" Then Between = "" Million = "" End If If First = "واحد" Then First = "" Million = "مليون" End If If First = "اثنان" Then First = "" Million = "مليونا" End If ChangeToDigits7 = First & Million & Between & Second End Function Private Function ChangeToDigits8(Temp As String) As String Dim Between As String Dim Million As String Dim First As String Dim Second As String Million = " مليون " First = ChangeToDigits2(Left(Temp, 2)) Second = ChangeToDigits6(Right(Temp, 6)) If Second <> "" Then Between = " و " Else Between = "" If First = "" Then Between = "" Million = "" End If If First = "واحد" Then First = "" Million = " مليون " End If If First = "اثنان" Then First = "" Million = "مليونا" End If ChangeToDigits8 = First & Million & Between & Second End Function Private Function ChangeToDigits9(Temp As String) As String Dim Between As String Dim Million As String Dim First As String Dim Second As String Million = " مليون " First = ChangeToDigits3(Left(Temp, 3)) Second = ChangeToDigits6(Right(Temp, 6)) If Second <> "" Then Between = " و " Else Between = "" If First = "" Then Between = "" Million = "" End If If First = "واحد" Then First = "" Million = " مليون " End If If First = "اثنان" Then First = "" Million = "مليونا" End If ChangeToDigits9 = First & Million & Between & Second End Function Public Function ChangeThisNumber(Allnumber As String) As String Dim Temp As String Dim Backed As String Dim Backed2 As String Dim Length As Integer Dim bigCur, smallCur As String Dim intNum As String Dim FloatNum As String Dim I As Integer Dim Found As Boolean Allnumber = Trim(Allnumber) If Not IsNumeric(Allnumber) Then ChangeThisNumber = "خطأ في الإدخال" Exit Function End If I = 1 Do While I <> Len(Allnumber) + 1 If Mid(Allnumber, I, 1) <> "." Then intNum = intNum & Mid(Allnumber, I, 1) Else Found = True GoTo Float End If I = I + 1 Loop Float: If Found Then I = I + 1 Do While I <> Len(Allnumber) + 1 FloatNum = FloatNum & Mid(Allnumber, I, 1) I = I + 1 Loop End If Temp = intNum Length = Len(Temp) If Length = 1 Then Backed = ChangeToDigits1(Temp) If Length = 2 Then Backed = ChangeToDigits2(Temp) If Length = 3 Then Backed = ChangeToDigits3(Temp) If Length = 4 Then Backed = ChangeToDigits4(Temp) If Length = 5 Then Backed = ChangeToDigits5(Temp) If Length = 6 Then Backed = ChangeToDigits6(Temp) If Length = 7 Then Backed = ChangeToDigits7(Temp) If Length = 8 Then Backed = ChangeToDigits8(Temp) If Length = 9 Then Backed = ChangeToDigits9(Temp) Temp = FloatNum Length = Len(Temp) If Length = 1 Then Backed2 = ChangeToDigits1(Temp) If Length = 2 Then Backed2 = ChangeToDigits2(Temp) If Length = 3 Then Backed2 = ChangeToDigits3(Temp) If Length = 4 Then Backed2 = ChangeToDigits4(Temp) If Length = 5 Then Backed2 = ChangeToDigits5(Temp) If Length = 6 Then Backed2 = ChangeToDigits6(Temp) If Length = 7 Then Backed2 = ChangeToDigits7(Temp) If Length = 8 Then Backed2 = ChangeToDigits8(Temp) If Length = 9 Then Backed2 = ChangeToDigits9(Temp) smallCur = StrSmallNameCurrency bigCur = StrLargeNameCurrency Dim Filse As String Dim Between As String Dim JD As String Between = " و " If Backed <> "" Then JD = " " & bigCur & " " Else JD = "" Between = "" End If If Backed2 <> "" Then Filse = " " & smallCur & " " Else Filse = "" Between = "" End If ChangeThisNumber = Backed & JD & Between & Backed2 & Filse End Function استخدام الدالة المعرفة ضع رقم في الخلية A1 وفي الخلية B1 ضع المعادلة التالية =ChangeThisNumber(A1) وإليك الملف المرفق مطبق فيه الدالة المعرفة .. تقبل وافر تقديري واحترامي Spell Number UDF Function Karim.rar

اللهم ما أصبح بي من نعمة أو بأحد من خلقك فمنك وحدك لا شريك لك فلك الحمد ولك الشكر.

أنا بستخدم أوفيس 2013 وليست موجودة فيه

بل كلاهما اضافة الى المتعة والفائدة التي نجدها في النقاش معك

وجزاكم الله خيرا اباخليل ! بس مافيش اعجاب ! او افضل اجابة !! كنت حاب ارسل لك خاص ! ولكن لايستقبل خاصك !! تحياتي

تمام .. فكرة جميلة وجديدة جزيت خيرا ،،،

حل جميل ورائع آمل شرح آلية المعادلة ( اكبر من او يساوي واحد "ناقص" رقم اليوم ) و ( اصغر من ثمانية "ناقص" رقم اليوم ) حقيقة هذه مثل : خشب الخبش .. يقف التفكير

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

استاذ طارق شكرا للافكار الجميلة والتطبيق السلس شكرا .......

مشكور استاذ طارق على هذا العمل العظيم ولى سؤال عند استدعاء فاتوره معينه والتعديل عليها وترحيلها تكرر نفس الفاتوره بالتعديل والمطلوب هو عند استدعاء فاتوره والتعديل عليها وترحيلها يقوم الفورم باستبدال الفاتوره التى تم تعديلها