محمدي عبد السميع

بسم الله الرحمن الرحيم الحمد لله الواحد القهار، العزيز الغفار، مكور الليل على النهار ، تذكرة لأولي القلوب والأبصار وتبصرة لذوي الألباب والاعتبار ، الذي أيقظ من خلقه من اصطفاه فزهدهم في هذه الدار، وشغلهم بمراقبته وإدامة الأفكار ، وملازمة الاتعاظ والاذكار، ووفقهم للدؤوب في طاعته والتأهب لدار القرار، والحذر مما يسخطه ويوجب دار البوار، والمحافظة على ذلك مع تغاير الأحوال والأطوار. أحمده أبلغ حمد وأزكاه، وأشمله وأنماه. أما بعد: رأيت أن أقدم عملا خالصا لوجه الله الكريم لعل الله يتغمدنا برحمته ولذا رأيت أنا الفقير إلى الله المحمدي عبد السميع عبد الغني أن أجمع الأكواد بطريقة منظمة تسهل للجميع الحصول عليها عند استخدام محرك البحث ، ولهذا ساقدم سلسلة من الأكواد كل كود بعنوان واضح يسهل الوصول له في موضوع مستقل وسأشرح كيفية استخدام الكود ماتيسر لي إن شاء الله وعلى الله قصد السبيل ****************************************** هذا كود التنقل الى اي صفحة في ملف اكسيل طريقة الاستفادة من الكود افتح ملف اكسيل اضغط على الرز ALT وانت ضاغط على الزر اضغط على F11 الموجود أعلا لوحة المفاتيح ستظهر شاشة الماكرو اضغط على موديول 1 سيتم فتح الموديول الصق فيه الكود الموجود تحت هذا السطر [/center] ' ' هذا الكود للعالم العلامة عبد الله باقسير Sub GO_TO() On Error Resume Next Application.CommandBars("Workbook Tabs").Controls("More Sheets...").Execute If Err.Number > 0 Then Err.Clear Application.CommandBars("Workbook Tabs").ShowPopup End If Activewindow.ScrollColumn = 1 Activewindow.ScrollRow = 1 On Error GoTo 0 End Sub في هذا الكود البسيط والمفيد عند الضغط على الزر ستنسدل قائمة بأسماء كل الصفحات الموجوده بالملف اختر منها الورقة التي تبعاها ودمتم في حفظ الله التنقل بين الصفحات.rar

حفظكم الله ورعاكم

بسم الله الرحمن الرحيم الحمد لله الواحد القهار، العزيز الغفار، مكور الليل على النهار ، تذكرة لأولي القلوب والأبصار وتبصرة لذوي الألباب والاعتبار ، الذي أيقظ من خلقه من اصطفاه فزهدهم في هذه الدار، وشغلهم بمراقبته وإدامة الأفكار ، وملازمة الاتعاظ والادكار، ووفقهم للدؤوب في طاعته والتأهب لدار القرار، والحذر مما يسخطه ويوجب دار البوار، والمحافظة على ذلك مع تغاير الأحوال والأطوار. أحمده أبلغ حمد وأزكاه، وأشمله وأنماه. أما بعد: رأيت أن أقدم عملا خالصا لوجه الله الكريم لعل الله يتغمدنا برحمته ولذا رأيت أنا الفقير إلى الله المحمدي عبد السميع عبد الغني أن أجمع الأكواد بطريقة منظمة تسهل للجميع الحصول عليها عند استخدام محرك البحث ، ولهذا ساقدم سلسلة من الأكواد كل كود بعنوان واضح يسهل الوصول له في موضوع مستقل وسأشرح كيفية استخدام الكود ماتيسر لي إن شاء الله وعلى الله قصد السبيل ****************************************** هذا كود طباعة بعد المعاينة في هذا الكود البسيط والمفيد سيتم الطباعة بعد ظهور رساله تسألك هل تود الطباعة بعد المعاينة فإذا كانت المعاينة تناسبك قل نعم وان لم تكن تناسبك وتريد التضبيط فقل لا طريقة الاستفادة من الكود افتح ملف اكسيل اضغط على الرز ALT وانت ضاغط على الزر اضغط على F11 الموجود أعلا لوحة المفاتيح ستظهر شاشة الماكرو اضغط على موديول 1 سيتم فتح الموديول الصق فيه الكود الموجود تحت هذا السطر [/center] ' هذا الكود للمهندس علي السحيب Sub معاينة_مع_الطباعة() ActiveWindow.SelectedSheets.PrintPreview A = MsgBox("هل تود الطباعة بعد المعاينة؟", vbYesNo + vbQuestion, "طباعة") If A = vbYes Then With ActiveSheet .PrintOut End With End If Range("A1").Activate End Sub ودمتم في حفظ الله معاينة طباعة مع امكانية الطباعه.rar

جزاكم الله خيرا

جزاك الله كل خيرأخي أبو حنين

إخواني الأحباب حفظكم الله ورعاكم وجعلني الله عند حسن ظنكم

بسم الله الرحمن الرحيم الحمد لله الواحد القهار، العزيز الغفار، مكور الليل على النهار ، تذكرة لأولي القلوب والأبصار وتبصرة لذوي الألباب والاعتبار ، الذي أيقظ من خلقه من اصطفاه فزهدهم في هذه الدار، وشغلهم بمراقبته وإدامة الأفكار ، وملازمة الاتعاظ والادكار، ووفقهم للدؤوب في طاعته والتأهب لدار القرار، والحذر مما يسخطه ويوجب دار البوار، والمحافظة على ذلك مع تغاير الأحوال والأطوار. أحمده أبلغ حمد وأزكاه، وأشمله وأنماه. أما بعد: رأيت أن أقدم عملا خالصا لوجه الله الكريم لعل الله يتغمدنا برحمته ولذا رأيت أنا الفقير إلى الله المحمدي عبد السميع عبد الغني أن أجمع الأكواد بطريقة منظمة تسهل للجميع الحصول عليها عند استخدام محرك البحث ، ولهذا ساقدم سلسلة من الأكواد كل كود بعنوان واضح يسهل الوصول له في موضوع مستقل وسأشرح كيفية استخدام الكود ماتيسر لي إن شاء الله وعلى الله قصد السبيل ****************************************** هذا كود ترحيل أعمدة معينة في هذا الكود سيتم ترحيل الأعمدة الموجودة في الصفحة المصدر ( الشيت ) ويمكن تغييرها الى أي أعمدة تبغاها ("a1:c1,z1,ai1,ar1,ba1,bl1,bm1,cd1,di1,dj1"). طريقة الاستفادة من الكود افتح ملف اكسيل اضغط على الرز ALT وانت ضاغط على الزر اضغط على F11 الموجود أعلا لوحة المفاتيح ستظهر شاشة الماكرو اضغط على موديول 1 سيتم فتح الموديول الصق فيه الكود الموجود تحت هذا السطر [/center] ''' هذا الكود للعالم العلامة / عبد الله باقشير Sub KH_START1() Dim R As Integer, M As Integer, N As Integer Sheets("كشف ناجح").Range("B7:Es1000").ClearContents Sheets("كشف الدور الثاني").Range("B7:Es1000").ClearContents ''' عدد الصفوف العليا في الصفحات المنقول اليها البيانات M = 6: N = 6: S = 6 Application.ScreenUpdating = False ''' بداية ونهاية صفوف الورقة المصدر For R = 11 To 700 ''' رقم عمود المعيار وكلمة المعيار If Cells(R, 113) = "ناجح" Then M = M + 1 ''' أسماء الأعمدة المطلوب نسخها Range("A" & R).Range("a1:c1,z1,ai1,ar1,ba1,bl1,bm1,cd1,di1,dj1").Copy ''' سيتم اللصق في هذا الشيت With Sheets("كشف ناجح") ''' سيتم اللصق بدءا من عمود .Range("B" & M).PasteSpecial xlPasteValues .Range("B" & M).PasteSpecial xlPasteFormats .Range("B" & M) = M - 6 End With Application.CutCopyMode = False ''' للصفحة الأخرى المطلوب الترحيل إليها 'رقم عمود المعيار وكلمة المعيار ElseIf Cells(R, 113) = "دور ثان في" Then ''' لترك صف اعلا كل صف N = N + 2 ''' أسماء الأعمدة المطلوب نسخها Range("A" & R).Range("a1:c1,z1,ai1,ar1,ba1,bl1,bm1,cd1,di1,dj1").Copy ''' سيتم اللصق في هذا الشيت With Sheets("كشف الدور الثاني") .Range("B" & N).PasteSpecial xlPasteValues .Range("B" & N).PasteSpecial xlPasteFormats .Range("B" & N) = (N - 6) / 2 End With Application.CutCopyMode = False End If Next MsgBox "تم ترحيل " & M - 6 & " طالب ناجح" & Chr(10) & Chr(10) & _ "تم ترحيل " & (N - 6) / 2 & " طالب دور ثاني", vbMsgBoxRight, "الحمدلله" Application.ScreenUpdating = True End Sub ودمتم في حفظ الله ترحيل مفيد باختبار اعمدة معينة.rar

حفظكم الله ورعاكم وجعلنا عند حسن الظن دائما

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

بسم الله الرحمن الرحيم الحمد لله الواحد القهار، العزيز الغفار،مكور الليل على النهار ، تذكرة لأولي القلوب والأبصار وتبصرة لذوي الألباب والاعتبار ، الذي أيقظ من خلقه من اصطفاه فزهدهم في هذه الدار، وشغلهم بمراقبته وإدامة الأفكار ، وملازمة الاتعاظ والادكار، ووفقهم للدؤوب في طاعته والتأهب لدار القرار، والحذر مما يسخطه ويوجب دار البوار، والمحافظة على ذلك مع تغاير الأحوال والأطوار. أحمده أبلغ حمد وأزكاه، وأشمله وأنماه. أما بعد: رأيت أن أقدم عملا خالصا لوجه الله الكريم لعل الله يتغمدنا برحمته ولذا رأيت أنا الفقير إلى الله المحمدي عبد السميع عبد الغني أن أجمع الأكواد بطريقة منظمة تسهل للجميع الحصول عليها عند استخدام محرك البحث ، ولهذا ساقدم سلسلة من الأكواد كل كود بعنوان واضح يسهل الوصول له في موضوع مستقل وسأشرح كيفية استخدام الكود ماتيسر لي إن شاء الله وعلى الله قصد السبيل ****************************************** هذا كود ترحيل الصفحة كامله بشرط واحد على سبيل المثال عندنا درجات الطلاب وفيهم طلاب ناجحون وطلاب دور ثان وطلاب راسبون هذا الكود يفصل الطلاب الناجحون في ورقة ويفصل الطلاب الذين لهم حق الدخول في الدور الثاني في صفحة أخرى ويفصل الطلاب الراسبون في صفحة أخرى وهكذا طريقة الاستفادة من الكود افتح ملف اكسيل اضغط على الرز ALT وانت ضاغط على الزر اضغط على F11 الموجود أعلا لوحة المفاتيح ستظهر شاشة الماكرو اضغط على موديول 1 سيتم فتح الموديول الصق فيه الكود الموجود تحت هذا السطر Sub KH_START()[/center] ''' متغيرات بعدد الصفحات المطلوب الترحيل اليها Dim R As Integer, M As Integer, N As Integer, O As Integer ''' أسماء الصفحات المطلوب الترحيل اليها والمدى المطلوب مسح البيانات الثديمة منه Sheets("ناجح").Range("A11:DZ1000").ClearContents Sheets("دور ثان في").Range("A11:DZ1000").ClearContents Sheets("رسوب").Range("A11:DZ1000").ClearContents ''' عدد الصفوف العليا في الصفحات المنقول اليها البيانات M = 11: N = 11: O = 12 Application.ScreenUpdating = False ''' بداية ونهاية صفوف الورقة المصدر For R = 11 To 1000 ''''''''''''''''''''''''''''''''''''''''''''''''''''' ''' رقم عمود المعيار وكلمة المعيار If Cells(R, 113) = "ناجح" Then Range("A" & R).Resize(1, 115).Copy ''' سيتم اللصق في هذا الشيت Sheets("ناجح").Range("A" & M).PasteSpecial xlPasteValues Application.CutCopyMode = False M = M + 1 '''''''''''''''''''''''''''''''''''''''''''''''''''' ''' رقم عمود المعيار وكلمة المعيار ElseIf Cells(R, 113) = "دور ثان في" Then Range("A" & R).Resize(1, 115).Copy ''' سيتم اللصق في هذا الشيت Sheets("دور ثان في").Range("A" & N).PasteSpecial xlPasteValues Application.CutCopyMode = False ''' اجعل الرقم 1 الى الرقم 2وانظر في صفحة الدور الثاني بعد الترحيل N = N + 1 ''''''''''''''''''''''''''''''''''''''''''''''''''''' ElseIf Cells(R, 113) = "رسوب" Then Range("A" & R).Resize(1, 115).Copy Sheets("رسوب").Range("A" & O).PasteSpecial xlPasteValues Application.CutCopyMode = False ''' لترك صف فارغ اعلا كل صف O = O + 2 End If ''''''''''''''''''''''''''''''''''''''''''''''''''''' Next MsgBox ("الحمد لله تـــم ترحيل الناجحين و الراسبين إلى أوراق عمل جديدة ") Application.ScreenUpdating = True End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''''' وإذا اردت زيادة عدد الصفحات الطلوب نقل وترحيل البيانات اليها ... سهلة إن شاء الله ماعليك إلا أن تضيف هذه الجزئيه في الكود مع كتابة اسم الصفحة الجديده والمعيار الجديد ''' رقم عمود المعيار وكلمة المعيار ElseIf Cells(R, 113) = "دور ثان في" Then Range("A" & R).Resize(1, 115).Copy ''' سيتم اللصق في هذا الشيت Sheets("دور ثان في").Range("A" & N).PasteSpecial xlPasteValues Application.CutCopyMode = False ''' اجعل الرقم 1 الى الرقم 2وانظر في صفحة الدور الثاني بعد الترحيل N = N + 1 ودمتم في حفظ الله ترحيل مفيد جدا كل الصفحة بشرط.rar

اشكرك اخي عبد الله غلى مداخلتك وبعد لايوجد في المكتبة زر تحميل المرفق

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

بسم الله الرحمن الرحيم الحمد لله الواحد القهار، العزيز الغفار،مكور الليل على النهار ، تذكرة لأولي القلوب والأبصار وتبصرة لذوي الألباب والاعتبار ، الذي أيقظ من خلقه من اصطفاه فزهدهم في هذه الدار، وشغلهم بمراقبته وإدامة الأفكار ، وملازمة الاتعاظ والادكار، ووفقهم للدؤوب في طاعته والتأهب لدار القرار، والحذر مما يسخطه ويوجب دار البوار، والمحافظة على ذلك مع تغاير الأحوال والأطوار. أحمده أبلغ حمد وأزكاه، وأشمله وأنماه. أما بعد: رأيت أن أقدم عملا خالصا لوجه الله الكريم لعل الله يتغمدنا برحمته ولذا رأيت أنا الفقير إلى الله المحمدي عبد السميع عبد الغني أن أجمع الأكواد بطريقة منظمة تسهل للجميع الحصول عليها عند استخدام محرك البحث ، ولهذا ساقدم سلسلة من الأكواد كل كود بعنوان واضح يسهل الوصول له في موضوع مستقل وسأشرح كيفية استخدام الكود ماتيسر لي إن شاء الله وعلى الله قصد السبيل ****************************************** هذا كود تفقيط ولاأروع يصلح لتحويل ارقام المجموع الكلي للطلاب الى تفقيط ويصلح ايضا لرجال الماهيات طريقة الاستفادة من الكود افتح ملف اكسيل اضغط على الرز ALT وانت ضاغط على الزر اضغط على F11 الموجود أعلا لوحة المفاتيح ستظهر شاشة الماكرو اضغط على موديول 1 سيتم فتح الموديول الصق فيه الكود الموجود تحت هذا السطر '-- Abo Hadi, 28/07/2003 --' '-- Last update on 28/07/2006 ' تم إضافة تشكيل بعض التفقيط الذي يسمح بالتشكيل الثابت 'وتم اضافة الحروف (ء و اء و أ) إلى الحروف التي لا يأتي بعدها ألف التنوين المنصوب ' وتم إضافة كلمة (فقط لا غير ) في آخر التفقيط 'وذلك في 9/8/2007 (يوم ميلادي) محمد صالح Option Explicit Public Const vArabic As Byte = 1 Public Const vMale As Byte = 0 Public Const vFemale As Byte = 1 Private Function myNz(ByVal InValue, Optional ByVal ValueIfNull = Null) myNz = IIf(IsNull(InValue), IIf(IsNull(ValueIfNull), Empty, ValueIfNull), InValue) End Function Private Function Delete(S As String, Index As Integer, Count As Integer) As String Delete = Left(S, Index - 1) + _ Mid(S, Index + Count, Len(S)) End Function Private Function Insert(Source, S As String, Index As Integer) As String Dim LPart As String Dim RPart As String LPart = Left(S, Index - 1) RPart = Mid(S, Index, Len(S)) Insert = LPart & Source & RPart End Function Private Function AddAnd(S1 As String, S2 As String, S3 As String, _ And_ As String, Lang As Byte) As String Dim InAnd_ As String Dim CollectS As String If Lang = vArabic Then InAnd_ = " " + And_ Else InAnd_ = And_ + " " If (S1 <> "") And (S2 <> "") Then And_ = InAnd_ Else And_ = "" CollectS = S1 + And_ + S2 If (CollectS <> "") And (S3 <> "") Then And_ = InAnd_ Else And_ = "" AddAnd = CollectS + And_ + S3 End Function Private Function S2Double(Single_ As Variant, Sex As Byte) As String Dim LLeter As Integer Dim K As Byte Dim Sngl_1 As String Dim Sngl_2 As String K = InStr(1, Single_ & " ", " ") Sngl_1 = Left(Single_, K - 1) Sngl_2 = "" If K < Len(Single_) Then Sngl_2 = Mid(Single_, K + 1, Len(Single_)) End If If Sngl_2 <> "" Then If Right(Sngl_2, 1) = "ة" Then Sngl_2 = Left(Sngl_2, Len(Sngl_2) - 1) & "تانِ" Else Sngl_2 = Sngl_2 & "انِ" End If End If If Sngl_1 <> "" Then LLeter = Asc(Right(Sngl_1, 1)) Select Case LLeter Case 201 ' "ة" Sngl_1 = Left(Sngl_1, Len(Sngl_1) - 1) & "تانِِ" Case 236 ' "ى" Sngl_1 = Left(Sngl_1, Len(Sngl_1) - 1) & "يانِ" Case 199 ' "ا" Sngl_1 = Left(Sngl_1, Len(Sngl_1) - 1) & "وانِ" Case 193 ' "ء" If Right(Sngl_1, 2) = "اء" Then If Sex = 1 Then Sngl_1 = Left(Sngl_1, Len(Sngl_1) - 1) & "وانِ" Else Sngl_1 = Sngl_1 & "انِ" End If End If Case Else If Sngl_1 <> "" Then Sngl_1 = Sngl_1 & "انِ" End Select If Sngl_2 <> "" Then S2Double = Sngl_1 & " " & Sngl_2 Else S2Double = Sngl_1 End If End Function Private Function Fmale(num As Byte, Sex As Byte, Female()) As String Dim Two(1 To 4) As String Dim InSex As Byte Two(1) = "أحدَ" Two(2) = "اثنانِ" Two(3) = "إحدَى" Two(4) = "ة" Select Case Sex Case vMale: Select Case num Case 1: Fmale = Mid(Female(1), 1, 4) Case 2: Fmale = Two(2) Case 8: Fmale = Female(num) + "ي" + Two(4) Case 3 To 7, 9, 10: Fmale = Female(num) + Two(4) Case 11: Fmale = Two(1) + " " + Female(10) Case 12: Fmale = Mid(Two(2), 1, 4) + " " + Female(10) Case 13 To 19: Fmale = Female(num - 10) + Two(4) + " " + Female(10) End Select Case vFemale: Select Case num Case 1 To 10: Fmale = Female(num) Case 11: Fmale = Two(3) + " " + Female(10) + Two(4) Case 12: Fmale = Mid(Female(2), 1, 5) + " " + Female(10) + Two(4) Case 13 To 19: Fmale = Female(num - 10) + " " + Female(10) + Two(4) End Select End Select End Function Private Function Tens(num As Byte, Female()) As String Const Noon = "ونَ" Select Case num Case 2: Tens = Female(10) + Noon Case 3 To 9: Tens = Female(num) + Noon End Select End Function Private Function Hunds(num As Byte, Female()) As String Const Hund = "مائة" Select Case num Case 1: Hunds = Hund Case 2: Hunds = Mid(Hund, 1, 3) + Mid(Female(2), 4, 3) Case 3 To 9: Hunds = Female(num) + Hund End Select End Function Private Function Tenteen(num As Byte, ETens()) As String Const een = "een" num = num Mod 10 Select Case num Case 3 To 9: Tenteen = Mid(ETens(num), 1, Len(ETens(num)) - 1) + een End Select End Function Private Function EHunds(num As Byte, ESingle()) As String EHunds = ESingle(num) + " hundred" End Function Private Function AOnly(Num_ As String, FracS As String, Single_ As String, _ Plural As String, Parts As Byte, Sex As Byte, Dec As Byte) As String Const And_ As String * 1 = "و" Const Lang = vArabic Dim PartNum(0 To 7) As Long Dim Result1(0 To 8) As String Dim Parts_(0 To 13) As String Dim Female(1 To 10) As Variant Dim TempI As Byte Dim Sex2 As Byte Dim K As Byte Dim Only_ As String Dim OnlyPart As String Dim Part_ As String Dim TempS As String Dim Sngl_1 As String Dim Sngl_2 As String Dim N1 As Byte, N2 As Byte, N3 As Byte Dim N1_ As String, N2_ As String, N3_ As String If Val(Num_) = 0 Then If FracS = "" Then AOnly = RTrim("لا شيءَ " & Single_) ' تم تغيير صفر إلى لا شيء Else AOnly = FracS & " " & Single_ End If Exit Function End If Female(1) = "واحدة" Female(2) = "اثنتانِ" Female(3) = "ثلاث" Female(4) = "أربع" Female(5) = "خمس" Female(6) = "ست" Female(7) = "سبع" Female(8) = "ثمان" Female(9) = "تسع" Female(10) = "عشر" Parts_(0) = "" Parts_(1) = "ألف" Parts_(2) = "مليونَ" Parts_(3) = "مليار" Parts_(4) = "ترليونَ" Parts_(5) = "كدرليونَ" Parts_(6) = "كوينتليونَ" Parts_(7) = "" Parts_(8) = "آلافٍ" Parts_(9) = "ملايينَ" Parts_(10) = "ملياراتٍ" Parts_(11) = "ترليوناتٍ" Parts_(12) = "كدرليوناتٍ" Parts_(13) = "كوينتليوناتٍ" K = InStr(1, Single_ & " ", " ") Sngl_1 = Left(Single_, K - 1) Sngl_2 = "" If K < Len(Single_) Then Sngl_2 = Mid(Single_, K + 1, Len(Single_)) End If If Sngl_2 <> "" And InStr(2, Plural, Sngl_2) > 0 Then Sngl_2 = "" End If For K = 0 To Parts - 1 PartNum(K) = Val(Mid(Num_, (K * 3) + 1, 3)) Next K Sex2 = Sex For K = 0 To (Parts - 1) If K = (Parts - 1) Then Sex = Sex2 Else Sex = vMale TempS = Mid(Num_, (K * 3) + 1, 3) TempI = Val(Mid(TempS, 2, 2)) N1 = Val(Mid(TempS, 1, 1)) N2 = Val(Mid(TempS, 2, 1)) N3 = Val(Mid(TempS, 3, 1)) '{------------------------------------------} N1_ = "": N2_ = "": N3_ = "" If N1 > 0 Then N1_ = Hunds(CByte(N1), Female()) If PartNum(K) = 200 Then N1_ = Mid(N1_, 1, Len(N1_) - 1) Select Case TempI Case 1 To 2: If K = Parts - 1 Then If FracS <> "" Then N3_ = Fmale(N3, CByte(Sex), Female()) 'Sex Case 3 To 19: N3_ = Fmale(TempI, CByte(Sex), Female()) Case 20 To 99: N2_ = Tens(CByte(N2), Female()) If N3 > 0 Then N3_ = Fmale(N3, CByte(Sex), Female()) If (N3 Mod 10 = 1) And (Sex = vFemale) Then N3_ = "إحدَى" End Select OnlyPart = AddAnd(N1_, N3_, N2_, And_, Lang) '{------------------------------------------} If PartNum(K) > 100 Then Select Case TempI Case 1, 2: OnlyPart = AddAnd(OnlyPart, Parts_(Parts - K - 1), "", "", Lang) End Select End If '{------------------------------------------} Part_ = "" If PartNum(K) > 0 Then Part_ = Parts_(Parts - K - 1) If Part_ <> "" Then Select Case TempI Case 2: Part_ = Part_ + "انِ" Case 3 To 10: Part_ = Parts_((Parts - K - 1) + 7) Case 11 To 99: Part_ = Part_ + "اً" End Select End If End If '{------------------------------------------} If Part_ <> "" Then If TempI >= 1 And TempI <= 2 Then OnlyPart = AddAnd(OnlyPart, Part_, "", And_, Lang) Else OnlyPart = AddAnd(OnlyPart, Part_, "", "", Lang) End If End If Result1(K) = OnlyPart Next K '{------------------------------------------} For K = 0 To Parts - 1 Only_ = AddAnd(Only_, Result1(K), "", And_, Lang) Next K If FracS <> "" Then If Only_ <> "" Then FracS = " " + FracS Only_ = AddAnd(Only_, FracS, "", And_, Lang) End If If Only_ <> "" Then If Mid(Only_, Len(Only_), 1) = "ا" Then If Mid(Only_, Len(Only_) - 1, 2) <> "تا" Then Only_ = Mid(Only_, 1, Len(Only_) - 1) End If End If If TempS = "000" Then If Mid(Only_, Len(Only_) - 1, 2) = "ان" Then Only_ = Mid(Only_, 1, Len(Only_) - 1) End If End If End If '{------------------------------------------} If FracS = "" Then Select Case TempI Case 0: If Only_ <> "" Then Only_ = AddAnd(Only_, Single_, "", "", Lang) Case 1: Only_ = AddAnd(Only_, AddAnd(Single_, Fmale(1, CByte(Sex), Female()), "", "", Lang), "", And_, Lang) Case 2: Only_ = AddAnd(Only_, AddAnd(S2Double(Single_, CByte(Sex)), Fmale(2, CByte(Sex), Female()), "", "", Lang), "", And_, Lang) Case 3 To 10: If Sngl_2 <> "" Then If Right(Sngl_2, 1) = "ة" Then Only_ = AddAnd(Only_, Plural, Sngl_2, "", Lang) Else Only_ = AddAnd(Only_, Plural, Sngl_2 & "ة", "", Lang) End If Else Only_ = AddAnd(Only_, Plural, "", "", Lang) End If Case 11 To 99: If Sngl_1 <> "" Then Only_ = AddAnd(Only_, Sngl_1, "", "", Lang) N1_ = Mid(Only_, Len(Only_), 1) Select Case N1_ Case "ة", "ى", "أ", "ء", "اء" Case Else Only_ = Only_ + "اً" End Select N1_ = Mid(Only_, Len(Only_) - 2, 3) 'هذا الشرط لحل مشكلة عدم التمييز بين "ء" و "ل" 2002/08/24 If N1_ = "اءا" And Asc(Right(Sngl_1, 1)) = 193 Then Only_ = Left(Only_, Len(Only_) - 1) End If If Sngl_2 <> "" Then If Right(Only_, 1) = "ا" Then Only_ = AddAnd(Only_, Sngl_2 & "اً", "", "", Lang) Else Only_ = AddAnd(Only_, Sngl_2, "", "", Lang) End If Else Only_ = AddAnd(Only_, Sngl_2, "", "", Lang) End If End If End Select Else Only_ = AddAnd(Only_, Sngl_1, Sngl_2, "", Lang) End If AOnly = (Only_) End Function Private Function S_Only(InNum As Variant, Lang As Byte, FracType As Byte) As Variant Dim Num_ As String Dim K As Byte Dim Dec As Byte Dim FType As Byte If IsNull(InNum) Then S_Only = Null Exit Function End If Num_ = CStr(InNum) K = InStr(1, Num_, ".", 1) If K > 0 Then Dec = Len(Num_) - K 'If Dec < 2 Then Dec = 2 Else Dec = 0 End If FType = FracType If FType <> 2 Then FType = 1 S_Only = B_Only(InNum, Lang, 0, Dec, "", "", 0, "", "", FType) End Function Private Function B_Only(InNum As Variant, Lang As Byte, Sex As Byte, Dec As Byte, _ Single_ As String, Plural As String, _ FSex As Byte, SFrac As String, PFrac As String, _ FracType As Byte) As Variant Dim Leng As Byte Dim Parts As Byte Dim K As Byte Dim FracVal As Double Dim Num_ As String Dim FracS As String Dim FracNum As String Dim Only As String Dim And_ As String If IsNull(InNum) Then B_Only = Null Exit Function End If If Dec > 6 Then Dec = 6 Num_ = Format(InNum, "0" & IIf(Dec > 0, ".", "") & String(Dec, "0")) If Dec > 0 Then FracS = "0." & Right(Num_, Dec) Else FracS = "" If Dec > 0 Then Num_ = Left(Num_, Len(Num_) - Dec - 1) FracVal = Val(FracS) Do While Len(FracS) < Dec + 2 FracS = Insert(FracS, "0", 1) Loop DoProcess: If FracVal = 0 Then FracS = "" FracNum = Trim(Mid(FracS, 3, Len(FracS))) If FracS <> "" Then Select Case FracType Case 2 Select Case Lang Case vArabic: FracS = "1" & String(Dec, "0") & "/" & CDbl(Format(FracNum, String(Dec, "0"))) End Select Case 3 Select Case Lang Case vArabic: FracS = CLng(FracNum) & " " & IIf(FracNum >= 3 And FracNum <= 10, PFrac, SFrac) End Select Case 4 Leng = Len(FracNum) Parts = Fix((Leng + 2) / 3) For K = 1 To (Parts * 3) - Leng FracNum = Insert("0", FracNum, 1) Next K Select Case Lang Case vArabic: FracS = AOnly(FracNum, "", SFrac, PFrac, Parts, FSex, FracType) End Select End Select End If Leng = Len(Num_) Parts = Fix((Leng + 2) / 3) If Parts > 7 Then B_Only = InNum Exit Function End If For K = 1 To (Parts * 3) - Leng Num_ = Insert("0", Num_, 1) Next K Select Case FracType Case 1, 2 Select Case Lang Case vArabic: Only = AOnly(Num_, FracS, Single_, Plural, Parts, Sex, Dec) End Select Case 3, 4 Select Case Lang Case vArabic: Only = AOnly(Num_, "", Single_, Plural, Parts, Sex, Dec) If CDbl(Num_) = 0 And FracS <> "" Then Only = "" If FracType = 3 Then And_ = "و " Else And_ = "و" If FracS <> "" Then Only = AddAnd(Only, FracS, "", And_, CByte(Lang)) End Select End Select If Only <> "" Then Select Case Lang Case vArabic: B_Only = Only End Select End If End Function 'يمكنك تغيير كلمة جنيه بأي معدود مفرد وكلمة جنيهات بأي معدود جمع وكذلك الحال مع الكسر وجنس المعدود أو الكسر (0) للمذكر و (1) للمؤنث ' تم إضافة هذه الملاحظات بواسطة محمد صالح حتى يتم استعمالها في الاستعلامات Function ArbNum2Text(ByVal InNum, _ Optional ByVal DecimalPlaces = 2, _ Optional ByVal FractionType = 4, _ Optional ByVal CurrencySingle = "جنيه", _ Optional ByVal CurrencyPlural = "جنيهات", _ Optional ByVal CurrencySex = 0, _ Optional ByVal FractionSingle = "قرش", _ Optional ByVal FractionPlural = "قروش", _ Optional ByVal FractionSex = 0) As Variant Dim Negative As String If IsNull(InNum) Then ArbNum2Text = Null Exit Function Else If InNum < 0 Then InNum = Abs(InNum) Negative = "سالبُ " End If End If If IsNull(FractionType) Then FractionType = 1 If myNz(CurrencySingle) = Empty Or myNz(CurrencyPlural) = Empty Then If Not IsNull(DecimalPlaces) Then InNum = Format(InNum, "0" & IIf(DecimalPlaces > 0, ".", "") & String(DecimalPlaces, "0")) End If ArbNum2Text = Negative & S_Only(InNum, vArabic, CByte(FractionType)) Exit Function End If If IsNull(DecimalPlaces) Then DecimalPlaces = 2 InNum = Format(InNum, "0" & IIf(DecimalPlaces > 0, ".", "") & String(DecimalPlaces, "0")) 'If InNum <> Fix(InNum) Then If Val(Right(InNum, DecimalPlaces)) > 0 Then If myNz(FractionSingle) = Empty Or myNz(FractionPlural) = Empty Then If FractionType > 2 Then FractionType = 1 End If End If ' تم إضافة كلمة فقط لا غير في آخر التفقيط بواسطة محمد صالح Dim m m = " فقطُ لا غيرَ" ArbNum2Text = Negative & _ B_Only(CDec(myNz(InNum, 0)), vArabic, CByte(myNz(CurrencySex)), _ CByte(myNz(DecimalPlaces)), CStr(myNz(CurrencySingle)), _ CStr(myNz(CurrencyPlural)), CByte(myNz(FractionSex)), _ CStr(myNz(FractionSingle)), CStr(myNz(FractionPlural)), _ CByte(myNz(FractionType))) & m End Function[/center] انتقل الى صفحة الإكسيل واكتب في الخلية B6 اي رقم مثلا 50 وفي أي خليه أخرى ولتكن الخلية D6 اكتب الجملة التاليه =ArbNum2Text(B6;1;1;"درجـة";"درجـات";1;"جزء";"أجزاء";1) اضغط انتر سيظهر تفقيط الرقم وإذا أردنا الاستفادة من الكود في الماهيات نضع في الخليه D6 هذه الجمله =" فقط "&ArbNum2Text(B6; 2;3;"جنيه";"جنيهات";1;"قرش";"قروش";1) أو اكتب هذه الجمله = "الصافي : " & ArbNum2Text(B6) ودمتم في حفظ الله كود تفقيط مفيد باستخدامات مختلفة.rar

بسم الله الرحمن الرحيم الحمد لله الواحد القهار، العزيز الغفار،مكور الليل على النهار ، تذكرة لأولي القلوب والأبصار وتبصرة لذوي الألباب والاعتبار ، الذي أيقظ من خلقه من اصطفاه فزهدهم في هذه الدار، وشغلهم بمراقبته وإدامة الأفكار ، وملازمة الاتعاظ والادكار، ووفقهم للدؤوب في طاعته والتأهب لدار القرار، والحذر مما يسخطه ويوجب دار البوار، والمحافظة على ذلك مع تغاير الأحوال والأطوار. أحمده أبلغ حمد وأزكاه، وأشمله وأنماه. أما بعد: رأيت أن أقدم عملا خالصا لوجه الله الكريم لعل الله يتغمدنا برحمته ولذا رأيت أن أجمع الأكواد بطريقة منظمة تسهل للجميع الحصول عليها عند استخدام محرك البحث ، ولهذا ساقدم سلسلة من الأكواد كل كود بعنوان واضح يسهل الوصول له في موضوع مستقل وسأشرح كيفية استخدام الكود ماتيسر لي إن شاء الله وعلى الله قصد السبيل ****************************************** الكود الاول هذا كود يجعل صفحة الاكسيل عندما تكتب فيها تكتب باللغة العربيه دائما حتى ولو كانت لغة الكتابة في لوحة المفاتيح انجليزي طريقة الاستفادة من الكود افتح ملف اكسيل اضغط على الرز ALT وانت ضاغط على الزر اضغط على F11 الموجود أعلا لوحة المفاتيح ستظهر شاشة الماكرو اضغط على This Workbook ستجد Private Sub Workbook_Open() hosami "00000401", 1 End Sub انسخه والصقة في ملفك الجديد في نفس الموقع This Workbook ثم اضغط على موديول 1 سيتم فتح الموديول هذا Declare Function hosami Lib _ "user32" Alias "LoadKeyboardLayoutA" (ByVal A As String _ , ByVal B As Long) As Long انسخه وضعه في نفس المكان وهو موديول 1 في ملفك الجديد احفظ الملف واعد فتحه ولاحظ لغة الكتابه في لوحة المفاتيح ودمتم في حفظ الله تغيير لغة الكي بورد الى العربي.rar تغيير لغة الكي بورد الى العربي بطريقة اخرى.rar

اريد ظهور الاسم إلى محمدي عبد السميع عبد الغني وتظهر دائما هذه الرساله *************************************** You must enter a name longer than 3 characters and shorter than 26. تغيير اسم الظهور You have made 0 of 5 display name changes since 15 Apr 2012. You are permitted to make 5 changes in a 10 day period. Changing your display name will not affect your log in details. ما العمل ؟

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

بسم الله الرحمن الرحيم الحمد لله الواحد القهار، العزيز الغفار،مكور الليل على النهار ، تذكرة لأولي القلوب والأبصار وتبصرة لذوي الألباب والاعتبار ، الذي أيقظ من خلقه من اصطفاه فزهدهم في هذه الدار، وشغلهم بمراقبته وإدامة الأفكار ، وملازمة الاتعاظ والادكار، ووفقهم للدؤوب في طاعته والتأهب لدار القرار، والحذر مما يسخطه ويوجب دار البوار، والمحافظة على ذلك مع تغاير الأحوال والأطوار. أحمده أبلغ حمد وأزكاه، وأشمله وأنماه. أما بعد: رأيت أن أقدم عملا خالصا لوجه الله الكريم لعل الله يتغمدنا برحمته ولذا رأيت أن أجمع الأكواد بطريقة منظمة تسهل للجميع الحصول عليها عند استخدام محرك البحث ، ولهذا ساقدم سلسلة من الأكواد كل كود بعنوان واضح يسهل الوصول له في موضوع مستقل وسأشرح كيفية استخدام الكود ماتيسر لي إن شاء الله وعلى الله قصد السبيل ****************************************** الكود الاول هذا كود يجعل صفحة الاكسيل عندما تكتب فيها تكتب باللغة العربيه دائما حتى ولو كانت لغة الكتابة في لوحة المفاتيح انجليزي طريقة الاستفادة من الكود افتح ملف اكسيل اضغط على الرز ALT وانت ضاغط على الزر اضغط على F11 الموجود أعلا لوحة المفاتيح ستظهر شاشة الماكرو اضغط على This Workbook ستجد Private Sub Workbook_Open() hosami "00000401", 1 End Sub انسخه والصقة في ملفك الجديد في نفس الموقع This Workbook ثم اضغط على موديول 1 سيتم فتح الموديول هذا Declare Function hosami Lib _ "user32" Alias "LoadKeyboardLayoutA" (ByVal A As String _ , ByVal B As Long) As Long انسخه وضعه في نفس المكان وهو موديول 1 في ملفك الجديد احفظ الملف واعد فتحه ولاحظ لغة الكتابه في لوحة المفاتيح ودمتم في حفظ الله تغيير لغة الكي بورد الى العربي.rar تغيير لغة الكي بورد الى العربي بطريقة اخرى.rar

هذا هو الكود الخاص بالتفقيط كود تفقيط مفيد باستخدامات مختلفة.rar

كود تفقيط ولاأروع يصلح لتحويل ارقام المجموع الكلي للطلاب الى تفقيط ويصلح ايضا لرجال الماهيات '-- Abo Hadi, 28/07/2003 --' '-- Last update on 28/07/2006 ' تم إضافة تشكيل بعض التفقيط الذي يسمح بالتشكيل الثابت 'وتم اضافة الحروف (ء و اء و أ) إلى الحروف التي لا يأتي بعدها ألف التنوين المنصوب ' وتم إضافة كلمة (فقط لا غير ) في آخر التفقيط 'وذلك في 9/8/2007 (يوم ميلادي) محمد صالح Option Explicit Public Const vArabic As Byte = 1 Public Const vMale As Byte = 0 Public Const vFemale As Byte = 1 Private Function myNz(ByVal InValue, Optional ByVal ValueIfNull = Null) myNz = IIf(IsNull(InValue), IIf(IsNull(ValueIfNull), Empty, ValueIfNull), InValue) End Function Private Function Delete(S As String, Index As Integer, Count As Integer) As String Delete = Left(S, Index - 1) + _ Mid(S, Index + Count, Len(S)) End Function Private Function Insert(Source, S As String, Index As Integer) As String Dim LPart As String Dim RPart As String LPart = Left(S, Index - 1) RPart = Mid(S, Index, Len(S)) Insert = LPart & Source & RPart End Function Private Function AddAnd(S1 As String, S2 As String, S3 As String, _ And_ As String, Lang As Byte) As String Dim InAnd_ As String Dim CollectS As String If Lang = vArabic Then InAnd_ = " " + And_ Else InAnd_ = And_ + " " If (S1 <> "") And (S2 <> "") Then And_ = InAnd_ Else And_ = "" CollectS = S1 + And_ + S2 If (CollectS <> "") And (S3 <> "") Then And_ = InAnd_ Else And_ = "" AddAnd = CollectS + And_ + S3 End Function Private Function S2Double(Single_ As Variant, Sex As Byte) As String Dim LLeter As Integer Dim K As Byte Dim Sngl_1 As String Dim Sngl_2 As String K = InStr(1, Single_ & " ", " ") Sngl_1 = Left(Single_, K - 1) Sngl_2 = "" If K < Len(Single_) Then Sngl_2 = Mid(Single_, K + 1, Len(Single_)) End If If Sngl_2 <> "" Then If Right(Sngl_2, 1) = "ة" Then Sngl_2 = Left(Sngl_2, Len(Sngl_2) - 1) & "تانِ" Else Sngl_2 = Sngl_2 & "انِ" End If End If If Sngl_1 <> "" Then LLeter = Asc(Right(Sngl_1, 1)) Select Case LLeter Case 201 ' "ة" Sngl_1 = Left(Sngl_1, Len(Sngl_1) - 1) & "تانِِ" Case 236 ' "ى" Sngl_1 = Left(Sngl_1, Len(Sngl_1) - 1) & "يانِ" Case 199 ' "ا" Sngl_1 = Left(Sngl_1, Len(Sngl_1) - 1) & "وانِ" Case 193 ' "ء" If Right(Sngl_1, 2) = "اء" Then If Sex = 1 Then Sngl_1 = Left(Sngl_1, Len(Sngl_1) - 1) & "وانِ" Else Sngl_1 = Sngl_1 & "انِ" End If End If Case Else If Sngl_1 <> "" Then Sngl_1 = Sngl_1 & "انِ" End Select If Sngl_2 <> "" Then S2Double = Sngl_1 & " " & Sngl_2 Else S2Double = Sngl_1 End If End Function Private Function Fmale(num As Byte, Sex As Byte, Female()) As String Dim Two(1 To 4) As String Dim InSex As Byte Two(1) = "أحدَ" Two(2) = "اثنانِ" Two(3) = "إحدَى" Two(4) = "ة" Select Case Sex Case vMale: Select Case num Case 1: Fmale = Mid(Female(1), 1, 4) Case 2: Fmale = Two(2) Case 8: Fmale = Female(num) + "ي" + Two(4) Case 3 To 7, 9, 10: Fmale = Female(num) + Two(4) Case 11: Fmale = Two(1) + " " + Female(10) Case 12: Fmale = Mid(Two(2), 1, 4) + " " + Female(10) Case 13 To 19: Fmale = Female(num - 10) + Two(4) + " " + Female(10) End Select Case vFemale: Select Case num Case 1 To 10: Fmale = Female(num) Case 11: Fmale = Two(3) + " " + Female(10) + Two(4) Case 12: Fmale = Mid(Female(2), 1, 5) + " " + Female(10) + Two(4) Case 13 To 19: Fmale = Female(num - 10) + " " + Female(10) + Two(4) End Select End Select End Function Private Function Tens(num As Byte, Female()) As String Const Noon = "ونَ" Select Case num Case 2: Tens = Female(10) + Noon Case 3 To 9: Tens = Female(num) + Noon End Select End Function Private Function Hunds(num As Byte, Female()) As String Const Hund = "مائة" Select Case num Case 1: Hunds = Hund Case 2: Hunds = Mid(Hund, 1, 3) + Mid(Female(2), 4, 3) Case 3 To 9: Hunds = Female(num) + Hund End Select End Function Private Function Tenteen(num As Byte, ETens()) As String Const een = "een" num = num Mod 10 Select Case num Case 3 To 9: Tenteen = Mid(ETens(num), 1, Len(ETens(num)) - 1) + een End Select End Function Private Function EHunds(num As Byte, ESingle()) As String EHunds = ESingle(num) + " hundred" End Function Private Function AOnly(Num_ As String, FracS As String, Single_ As String, _ Plural As String, Parts As Byte, Sex As Byte, Dec As Byte) As String Const And_ As String * 1 = "و" Const Lang = vArabic Dim PartNum(0 To 7) As Long Dim Result1(0 To 8) As String Dim Parts_(0 To 13) As String Dim Female(1 To 10) As Variant Dim TempI As Byte Dim Sex2 As Byte Dim K As Byte Dim Only_ As String Dim OnlyPart As String Dim Part_ As String Dim TempS As String Dim Sngl_1 As String Dim Sngl_2 As String Dim N1 As Byte, N2 As Byte, N3 As Byte Dim N1_ As String, N2_ As String, N3_ As String If Val(Num_) = 0 Then If FracS = "" Then AOnly = RTrim("لا شيءَ " & Single_) ' تم تغيير صفر إلى لا شيء Else AOnly = FracS & " " & Single_ End If Exit Function End If Female(1) = "واحدة" Female(2) = "اثنتانِ" Female(3) = "ثلاث" Female(4) = "أربع" Female(5) = "خمس" Female(6) = "ست" Female(7) = "سبع" Female(8) = "ثمان" Female(9) = "تسع" Female(10) = "عشر" Parts_(0) = "" Parts_(1) = "ألف" Parts_(2) = "مليونَ" Parts_(3) = "مليار" Parts_(4) = "ترليونَ" Parts_(5) = "كدرليونَ" Parts_(6) = "كوينتليونَ" Parts_(7) = "" Parts_(8) = "آلافٍ" Parts_(9) = "ملايينَ" Parts_(10) = "ملياراتٍ" Parts_(11) = "ترليوناتٍ" Parts_(12) = "كدرليوناتٍ" Parts_(13) = "كوينتليوناتٍ" K = InStr(1, Single_ & " ", " ") Sngl_1 = Left(Single_, K - 1) Sngl_2 = "" If K < Len(Single_) Then Sngl_2 = Mid(Single_, K + 1, Len(Single_)) End If If Sngl_2 <> "" And InStr(2, Plural, Sngl_2) > 0 Then Sngl_2 = "" End If For K = 0 To Parts - 1 PartNum(K) = Val(Mid(Num_, (K * 3) + 1, 3)) Next K Sex2 = Sex For K = 0 To (Parts - 1) If K = (Parts - 1) Then Sex = Sex2 Else Sex = vMale TempS = Mid(Num_, (K * 3) + 1, 3) TempI = Val(Mid(TempS, 2, 2)) N1 = Val(Mid(TempS, 1, 1)) N2 = Val(Mid(TempS, 2, 1)) N3 = Val(Mid(TempS, 3, 1)) '{------------------------------------------} N1_ = "": N2_ = "": N3_ = "" If N1 > 0 Then N1_ = Hunds(CByte(N1), Female()) If PartNum(K) = 200 Then N1_ = Mid(N1_, 1, Len(N1_) - 1) Select Case TempI Case 1 To 2: If K = Parts - 1 Then If FracS <> "" Then N3_ = Fmale(N3, CByte(Sex), Female()) 'Sex Case 3 To 19: N3_ = Fmale(TempI, CByte(Sex), Female()) Case 20 To 99: N2_ = Tens(CByte(N2), Female()) If N3 > 0 Then N3_ = Fmale(N3, CByte(Sex), Female()) If (N3 Mod 10 = 1) And (Sex = vFemale) Then N3_ = "إحدَى" End Select OnlyPart = AddAnd(N1_, N3_, N2_, And_, Lang) '{------------------------------------------} If PartNum(K) > 100 Then Select Case TempI Case 1, 2: OnlyPart = AddAnd(OnlyPart, Parts_(Parts - K - 1), "", "", Lang) End Select End If '{------------------------------------------} Part_ = "" If PartNum(K) > 0 Then Part_ = Parts_(Parts - K - 1) If Part_ <> "" Then Select Case TempI Case 2: Part_ = Part_ + "انِ" Case 3 To 10: Part_ = Parts_((Parts - K - 1) + 7) Case 11 To 99: Part_ = Part_ + "اً" End Select End If End If '{------------------------------------------} If Part_ <> "" Then If TempI >= 1 And TempI <= 2 Then OnlyPart = AddAnd(OnlyPart, Part_, "", And_, Lang) Else OnlyPart = AddAnd(OnlyPart, Part_, "", "", Lang) End If End If Result1(K) = OnlyPart Next K '{------------------------------------------} For K = 0 To Parts - 1 Only_ = AddAnd(Only_, Result1(K), "", And_, Lang) Next K If FracS <> "" Then If Only_ <> "" Then FracS = " " + FracS Only_ = AddAnd(Only_, FracS, "", And_, Lang) End If If Only_ <> "" Then If Mid(Only_, Len(Only_), 1) = "ا" Then If Mid(Only_, Len(Only_) - 1, 2) <> "تا" Then Only_ = Mid(Only_, 1, Len(Only_) - 1) End If End If If TempS = "000" Then If Mid(Only_, Len(Only_) - 1, 2) = "ان" Then Only_ = Mid(Only_, 1, Len(Only_) - 1) End If End If End If '{------------------------------------------} If FracS = "" Then Select Case TempI Case 0: If Only_ <> "" Then Only_ = AddAnd(Only_, Single_, "", "", Lang) Case 1: Only_ = AddAnd(Only_, AddAnd(Single_, Fmale(1, CByte(Sex), Female()), "", "", Lang), "", And_, Lang) Case 2: Only_ = AddAnd(Only_, AddAnd(S2Double(Single_, CByte(Sex)), Fmale(2, CByte(Sex), Female()), "", "", Lang), "", And_, Lang) Case 3 To 10: If Sngl_2 <> "" Then If Right(Sngl_2, 1) = "ة" Then Only_ = AddAnd(Only_, Plural, Sngl_2, "", Lang) Else Only_ = AddAnd(Only_, Plural, Sngl_2 & "ة", "", Lang) End If Else Only_ = AddAnd(Only_, Plural, "", "", Lang) End If Case 11 To 99: If Sngl_1 <> "" Then Only_ = AddAnd(Only_, Sngl_1, "", "", Lang) N1_ = Mid(Only_, Len(Only_), 1) Select Case N1_ Case "ة", "ى", "أ", "ء", "اء" Case Else Only_ = Only_ + "اً" End Select N1_ = Mid(Only_, Len(Only_) - 2, 3) 'هذا الشرط لحل مشكلة عدم التمييز بين "ء" و "ل" 2002/08/24 If N1_ = "اءا" And Asc(Right(Sngl_1, 1)) = 193 Then Only_ = Left(Only_, Len(Only_) - 1) End If If Sngl_2 <> "" Then If Right(Only_, 1) = "ا" Then Only_ = AddAnd(Only_, Sngl_2 & "اً", "", "", Lang) Else Only_ = AddAnd(Only_, Sngl_2, "", "", Lang) End If Else Only_ = AddAnd(Only_, Sngl_2, "", "", Lang) End If End If End Select Else Only_ = AddAnd(Only_, Sngl_1, Sngl_2, "", Lang) End If AOnly = (Only_) End Function Private Function S_Only(InNum As Variant, Lang As Byte, FracType As Byte) As Variant Dim Num_ As String Dim K As Byte Dim Dec As Byte Dim FType As Byte If IsNull(InNum) Then S_Only = Null Exit Function End If Num_ = CStr(InNum) K = InStr(1, Num_, ".", 1) If K > 0 Then Dec = Len(Num_) - K 'If Dec < 2 Then Dec = 2 Else Dec = 0 End If FType = FracType If FType <> 2 Then FType = 1 S_Only = B_Only(InNum, Lang, 0, Dec, "", "", 0, "", "", FType) End Function Private Function B_Only(InNum As Variant, Lang As Byte, Sex As Byte, Dec As Byte, _ Single_ As String, Plural As String, _ FSex As Byte, SFrac As String, PFrac As String, _ FracType As Byte) As Variant Dim Leng As Byte Dim Parts As Byte Dim K As Byte Dim FracVal As Double Dim Num_ As String Dim FracS As String Dim FracNum As String Dim Only As String Dim And_ As String If IsNull(InNum) Then B_Only = Null Exit Function End If If Dec > 6 Then Dec = 6 Num_ = Format(InNum, "0" & IIf(Dec > 0, ".", "") & String(Dec, "0")) If Dec > 0 Then FracS = "0." & Right(Num_, Dec) Else FracS = "" If Dec > 0 Then Num_ = Left(Num_, Len(Num_) - Dec - 1) FracVal = Val(FracS) Do While Len(FracS) < Dec + 2 FracS = Insert(FracS, "0", 1) Loop DoProcess: If FracVal = 0 Then FracS = "" FracNum = Trim(Mid(FracS, 3, Len(FracS))) If FracS <> "" Then Select Case FracType Case 2 Select Case Lang Case vArabic: FracS = "1" & String(Dec, "0") & "/" & CDbl(Format(FracNum, String(Dec, "0"))) End Select Case 3 Select Case Lang Case vArabic: FracS = CLng(FracNum) & " " & IIf(FracNum >= 3 And FracNum <= 10, PFrac, SFrac) End Select Case 4 Leng = Len(FracNum) Parts = Fix((Leng + 2) / 3) For K = 1 To (Parts * 3) - Leng FracNum = Insert("0", FracNum, 1) Next K Select Case Lang Case vArabic: FracS = AOnly(FracNum, "", SFrac, PFrac, Parts, FSex, FracType) End Select End Select End If Leng = Len(Num_) Parts = Fix((Leng + 2) / 3) If Parts > 7 Then B_Only = InNum Exit Function End If For K = 1 To (Parts * 3) - Leng Num_ = Insert("0", Num_, 1) Next K Select Case FracType Case 1, 2 Select Case Lang Case vArabic: Only = AOnly(Num_, FracS, Single_, Plural, Parts, Sex, Dec) End Select Case 3, 4 Select Case Lang Case vArabic: Only = AOnly(Num_, "", Single_, Plural, Parts, Sex, Dec) If CDbl(Num_) = 0 And FracS <> "" Then Only = "" If FracType = 3 Then And_ = "و " Else And_ = "و" If FracS <> "" Then Only = AddAnd(Only, FracS, "", And_, CByte(Lang)) End Select End Select If Only <> "" Then Select Case Lang Case vArabic: B_Only = Only End Select End If End Function 'يمكنك تغيير كلمة جنيه بأي معدود مفرد وكلمة جنيهات بأي معدود جمع وكذلك الحال مع الكسر وجنس المعدود أو الكسر (0) للمذكر و (1) للمؤنث ' تم إضافة هذه الملاحظات بواسطة محمد صالح حتى يتم استعمالها في الاستعلامات Function ArbNum2Text(ByVal InNum, _ Optional ByVal DecimalPlaces = 2, _ Optional ByVal FractionType = 4, _ Optional ByVal CurrencySingle = "جنيه", _ Optional ByVal CurrencyPlural = "جنيهات", _ Optional ByVal CurrencySex = 0, _ Optional ByVal FractionSingle = "قرش", _ Optional ByVal FractionPlural = "قروش", _ Optional ByVal FractionSex = 0) As Variant Dim Negative As String If IsNull(InNum) Then ArbNum2Text = Null Exit Function Else If InNum < 0 Then InNum = Abs(InNum) Negative = "سالبُ " End If End If If IsNull(FractionType) Then FractionType = 1 If myNz(CurrencySingle) = Empty Or myNz(CurrencyPlural) = Empty Then If Not IsNull(DecimalPlaces) Then InNum = Format(InNum, "0" & IIf(DecimalPlaces > 0, ".", "") & String(DecimalPlaces, "0")) End If ArbNum2Text = Negative & S_Only(InNum, vArabic, CByte(FractionType)) Exit Function End If If IsNull(DecimalPlaces) Then DecimalPlaces = 2 InNum = Format(InNum, "0" & IIf(DecimalPlaces > 0, ".", "") & String(DecimalPlaces, "0")) 'If InNum <> Fix(InNum) Then If Val(Right(InNum, DecimalPlaces)) > 0 Then If myNz(FractionSingle) = Empty Or myNz(FractionPlural) = Empty Then If FractionType > 2 Then FractionType = 1 End If End If ' تم إضافة كلمة فقط لا غير في آخر التفقيط بواسطة محمد صالح Dim m m = " فقطُ لا غيرَ" ArbNum2Text = Negative & _ B_Only(CDec(myNz(InNum, 0)), vArabic, CByte(myNz(CurrencySex)), _ CByte(myNz(DecimalPlaces)), CStr(myNz(CurrencySingle)), _ CStr(myNz(CurrencyPlural)), CByte(myNz(FractionSex)), _ CStr(myNz(FractionSingle)), CStr(myNz(FractionPlural)), _ CByte(myNz(FractionType))) & m End Function جزاكم الله خيرا

Range("GX11:GX" & 12 + case_NO).ClearContents 'ÇáÌÒÁ ÇáÊÇáí íãÓÍ ÝÞØ ÇáãÌÇá ÇáãØáæÈ ãä ÇáÔíÊÇÊ ÇáÊí ÃÓãÇÄåÇ ãÓÌáÉ Ýí ÇáÌÒÁ ÇáÓÇÈÞ For sh = 1 To Sheets.Count For i = 1 To case_NO If Sheets(sh).Name = sht(i) Then Sheets(sh).Range("A11:U3000").ClearContents Next i Next sh جزء من كود به لغة عربية وتظهر بهذا الشكل الغريب المتصفح فاير فوكس12 والاوفيس 2003 يارب نجد حلا ظهور اللغه العربية بصورة غريبه في الكود.rar

كود للتنقل بين الصفحات مهما تغيرت اسماؤها جزاكم الله خيرا [/color][/size][/center] [size=6][color=#0000CD] ' ' åÐÇ ÇáßæÏ ááÚÇáã ÇáÚáÇãÉ ÛÈÏ Çááå ÈÇÞÓíÑ [/color][/size] [size=6][color=#0000CD]Sub GO_TO() On Error Resume Next Application.CommandBars("Workbook Tabs").Controls("More Sheets...").Execute If Err.Number > 0 Then Err.Clear Application.CommandBars("Workbook Tabs").ShowPopup End If ActiveWindow.ScrollColumn = 1 ActiveWindow.ScrollRow = 1 On Error GoTo 0 End Sub لاادري لماذا تظهر اللغة العربية بهذه الصورة التنقل بين الصفحات.rar

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

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

أكواد أحدهم لحساب العمر بالتاريخ الميلادي والثاني لحساب العمر بالتاريخ الهجري والثالث واجهه متميزة للمحترم عماد الحسامي ********* وأنا سائل أخاً إنتفع بشيء من الموضوع أن يدعو لي ولوالدي ، ومشايخي ، وسائر أحبابنا ، أجمعين،وكل من ساهم بكود او عمل ينتفع به ولاننسى الدعاء للحبيب الغالي الذي أفاض عليا بكرم زائد وهو العالم العلامة والبحر الفهامه / عبد الله باقشير وعلى الله الكريم اعتمادي ، وإليه تفويضي واستنادي، وحسببي الله ونعم الوكيل، ولا حول ولا قوة إلا بالله العزيز الحكيم كود حساب العمر بالتاريخ الميلادي.rar كود حساب العمر بالتاريخ الهجري.rar واجهه برنامج كنترول.rar

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