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

السلام عليكم ورحمة الله وبركاته كل عام وانتم بخير اطلب المسامحة ممن راسلني ولم يجد رد مني هديتي لكم بعد هذه الغيبة Option Explicit '========================================================" ' بسم الله الرحمن الرحيم " '========================================================" ' (دالة تحويل الرقم الى نص باللغة العربية (تفقيط " ' kh_TextNum " '========================================================" 'Num الرقم " '========================================================" 'sex جنس العملة " 'FALSE ( فارغ او صفر مذكر ) " 'TRUE ( أو اي رقم غير الصفر مؤنث ) " '========================================================" 'sNameCurr اسم العملة الرئيسية مفرد " 'pNameCurr اسم العملة الرئيسية جمع " 'NameCurrDec اسم العملة الكسرية " 'Decimal_Count طول الكسر افتراضـياً : بدون اظهار الكسر " '===============================================================================================================================================" 'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" '===============================================================================================================================================" ' ملاحظات ' (اولاً : العملة الرئيسية مثنى (يقوم بها الكود تلقائيا ' مع ملاحظة اذا اسم العملة ينتهي بالتاء المربوطة ' يجب ان يكتب كذلك وليس بالهاء ' ----------------------- ' ثانياً : اذا كانت العملة الرئيسية مفرد فارغاً تعتبر ' اسماء العملات (الجمع والكسري) فارغة تلقائيا ' ----------------------- 'ثالثاً : الكلمة الابتدائية بامكانك تغييرها او تجعلها فارغة Private Const MyBegTx As String = "فقط " ' "" ' ----------------------- ' MyTNum رابعا : يمكنك التغيير (اضافة,حذف,تحرير) في الثابت ' للفئات الصفرية للرقم ادناه Private Const MyTNum As String = "ألف-آلاف/مليون-ملايين/مليار-مليارات/بليون-بلايين/بليار-بليارات/ترليون-ترليونات/تريليار-تريليارات/كدرليون-كدرليونات" '===============================================================================================================================================" 'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" '===============================================================================================================================================" Function kh_TextNum(Num As String, Optional sex As Boolean = False, Optional sNameCurr As String = "", Optional pNameCurr As String = "", Optional NameCurrDec 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 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 = sNameCurr & "-" & IIf(pNameCurr = "", sNameCurr, IIf(sNameCurr = "", "", pNameCurr)) '====================================== 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), zt) Txt2 = IIf(ii - i, Trim(Spp(ii - i)), nCurr) pr = 1 + IIf(ii - i, 1, CInt(sex)) Txt = Txt & IIf(Len(Txt), " و", "") & kh_nText(MyMid, Txt2, pr, zt, CBool(sNameCurr <> "")) End If If i = ii Then If MyMid = 0 Then Txt = Txt & IIf(Len(Txt), " ", "صفر ") & sNameCurr Next '====================================== Txt = MyBegTx & Txt & kh_dText(Num, sNameCurr, NameCurrDec, Decimal_Count) '====================================== kh_Exit: kh_TextNum = 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, "") & " و" & nT1 If Num2 = 0 Then nT2 = nT1 nT = nT2 End Select '====================================== S = IIf(nT = "" Or iNum < 100, "", " و") 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) As String Dim Td$, Td1$ On Error 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 Len(Ndec) Then Ndec = " " & Ndec: Td1 = Td * CVar("1" & String(co, "0")) Else Ndec = " " & NCur: Td1 = Td Td1 = " و " & Chr(40) & Td1 & Chr(41) & Ndec 1: kh_dText = Td1 End Function دالة تحويل الرقم الى نص عربي.rar ================================================= الملف المعدل: هذا المرفق بامكانية تفقيط الكسر وامكانية ادخال كلمة نهاية النص دالة تحويل الرقم الى نص عربي.rar ================================================= رابط مباشر للملف

أستكمالا لسلسلة ماتستطيعة المعادلة مثلها مثل الكود هذه معادلة تبدو فى ظاهرها عادية ولكن فوائدها كبيرة جدا من حيث أنها تقوم بفصل الأسماء والأرقام ووضعها فى عمود مستقل مهما كان طول الأسم والرقم معتمدة فى ذلك على ( الفراغ(" ")مابين الأسماء وبعضها أو( ";") أو ("-" )أوالكومة (",") .......الخ ) وبهذا تكون هذه المعادلة بكل المقاييس ذات فائدة عظيمة لكل من يطلب مثل هذا الفصل وهم كثروا. ألى المعادلة متمنيا أن تكون ذات فائدة لكل من عانى من فصل الأسم أو الرقم أوفصل خليط من الأرقام والأسماء إخوتى وزملائى المرفق الثانى يتضمن مزيدا من الشروط وكيفية تغيير شرط المعادلة لتقوم بطرق الفصل بشروط مختلفة معادلة تقوم بفصل كل ماتريد.rar معادلة تقوم بفصل كل ماتريد 2.rar

هدية العام الهجري الجديد ******************************************* كود اضافة ازرار باسماء الشيتات في الصفحة الرئيسية وزر للرئيسية في كل شيت **************************************************************************** السلام عليكم هذا الموضوع مقدم هدية لاساتذة وقادة هذا الصرح العملاق وهو هدية خاصة ( بسيطة جدا جدا ) بمناسبة العام الهجري الجديد للاستاذ القدير العلامة الخبير عبد الله باقشير لأقدم له عرفانا بالجميل لبعض ما تعلمناه منه ونتعلمه دائما بارك الله فيه ... وجزاه الله عنا خيرا وارجو ان ينال الملف اعجابكم تقبلوا خالص تحياتي وكل عام وانتم بخير وسلام وعلي طاعة الله دائما اضافة ازرار باسماء الشيتات وزر للرئيسية في كل شيت.rar

السلام عليكم و رحمة الله و بركاته الاخوة الاحباب بالمنتدى عن طريق ملف الاكسل المرفق يمكنك عمل بحث فى جهازك عن اي ملف عن طريق الاكسل و قمت بعمل واجهتين عربية و انجليزية و اضافة Hyperlink ( ارتباط تشعبي ) لسهولة الوصول للملفات التي تم البحث عنها كما يمكنك اختيار او كتابة الدرايف او المسار الذي سيتم البحث فيه و اختيار الامتداد او اسم الملف الذي سيتم البحث عنه و أسأل الله العلى العظيم أن ينفعكم بهذا العمل و الله و الموفق و المستعان و السلام عليكم و رحمة الله و بركاته SEARCH HaNcOcK.rar

الحمد لله رب العالمين ، الذي أحسن خلق الإنسان و عدله ، و ألهمه نور الإيمان ، فزينه به وجمله وعلمه البيان فقدمه به و فضله ، و أفاض عليه خزائن العلوم فأكمله ثم أرسل ستراً من رحمته وأسبله ، ثم أمده بلسان يترجم عما حواه القلب و عقله ويكشف عنه ستره الذي أرسله ، و أطلق بالحق مقوله و أفصح بالشكر ما أولاه و خوله من علم حصله ، و نطق سهله اخواني الأعزاء ومعلميني الأجلاء وجميع أعضاء وزائري صرحنا التعليمي اوفيسنا في طلب عزيز جدا علي نفسي لاخي العزيز والحبيب أبو سلمي استاذنا // سعيد بيرم صاحب الروح الجميلة وخفة الظل المعهودة في تعديل مقاسات قالب الفورم (هدية 2014 ) الذي تم طرحه علي الرابط http://www.officena.net/ib/index.php?showtopic=50131 واضافة تقويم هجري وميلادي ومن بعد اذنه قمت بطرح الموضوع لتعميم الفائدة للجميع اهداء لشخصه المحبب علي قلوبنا ولا تنسونا من دعوة صالحة بصلاح الحال في ظهر الغيب اللهم إني أسألك خير هذه السنه ومابعدها,، واعوذ بك من شر هذه السنه وشر مابعدها..,, اللهم إني أسألك هذه السنه فتحــها ونصرها.. ونورهــــــا وبركتـــها وهداهــــا,, وأعوذ بك من شر مافيها باطنها وظاهرها ويصلح حال أمتنا العربية والأسلامية وحال اهلنا في مصر وسوريا ويولي فيهم من يصلح اللهم أمين تقبلوا جمعيا تحياتي واحترامي وتقديري User Form Templates.rar

اخواني الاحباء ارجو المساعدة في ترحيل بيانات من الصفحة 1 من جدول الى جدول في صفحة2 و صفحة 3 مع الشكر الجزيل المثال داخل الملف المرفق aburaji9.rar

الحمد _لله_ الذي بنعمته تقضى الحاجات

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

السلام عليكم اتقصد هكذا لمرفق 2010 معادلة الرصيد.rar

الاستاذ القدير احمدزمان بارك الله فيك جعل الله كل ذلك في ميزان حسناتك تقبل تحياتي

الأستاذ / إسلام السلام عليكم ورحمة الله وبركاته لأخفاء جميع الصفوف الزيادة أقف على أول صف منها وحدد هذا الصف بالكامل من بدايته وإضغط من لوحة المفاتيح على ctrl مع shift مع السهم الذي ناحيته أسفل جميعاً مرة واحدة يظهر لك نهاية الصفوف ثم اعمل عملية اخفاء فيتم إخفاء جميع الصفوف الزيادة وكذلك الأمر بالنسبة للأعمدة أقف على آخر عمود وحدده بالكامل وإضفط على المفاتيح ctrl مع shift مع السهم الذي ناحيته إلى آخر الأعمدة حسب استخدامك لصفحة الإكسيل فيتم تحديد جميع الأعمدة قم بإخفائها.

السلام عليكم جزاكم الله خيرا هذا كود يعمل على اي امتداد Option Explicit '====================================================== '====================================================== Sub RenameMe() Dim NewName As String, MyBook As String, MyPath As String, MyTyp As String, MyName As String '============================ On Error GoTo Err_kh_Name '============================ 1: NewName = InputBox("ادخل اسم الملف الجديد", "اسم الملف") If StrPtr(NewName) = 0 Then Exit Sub If Trim(NewName) = "" Then GoTo 1 '============================ With ThisWorkbook MyBook = .Name MyPath = .Path & Application.PathSeparator End With MyTyp = Mid$(MyBook, InStrRev(MyBook, ".")) MyName = Replace(MyBook, MyTyp, "") '============================ If NewName = MyName Then MsgBox "اسم الملف هذا هو نفس الاسم الحالي", vbOKOnly, "" GoTo 1 End If '============================ NewName = MyPath & NewName & MyTyp If Dir(NewName, vbDirectory) = vbNullString Then ThisWorkbook.SaveAs Filename:=NewName Kill MyPath & MyBook MsgBox "تم تعديل اسم الملف بنجاح", vbOKOnly, "الحمدلله" Else MsgBox "اسم الملف هذا موجود مسبقا", vbOKOnly, "" GoTo 1 End If '============================ Err_kh_Name: If Err Then MsgBox "Err.Number : " & Err.Number Err.Clear End If End Sub المرفق 2003 vvv.rar

تفضل 66666.rar

أخى الحبيب / أبو محمود تسلم ايديك على هذه الابداعات ولاثراء الموضوع هذه دالة معرفة لفصل الأسماء اعتمادا على وجود المسافة الفاصلة بينها Function rg_split(rng As Range, n As Integer) On Error Resume Next r = Split(rng) rg_split = r(n - 1) If Err.Number <> 0 Then rg_split = "" End Function دالة معرفة لفصل مكونات خلية الى عدة خلايا 1.rar

السلام عليكم الاستاذ القدير / mahmoud-lee ((( عميــــــــــــــــــد المعـــــــــــــــــــــادلات ))) هو لقب تستحقة عن جدارة بكل تأكيد لم اكن اعلم هذا اللقب عنك وبعد ان علمت قررت ان اشارك غيري في الثناء عليك انك تستحقه لا لشئ سوي انك لا تتاخر عن خدمة اخوانك زائريك في هذا الموقع العظيم فانت العميد والكبير والعلامة والجهبز وطالما كنت في عون وخدمة الاخرين فانت السيد

السلام عليكم الاستاذ القدير / mahmoud-lee ((( عميــــــــــــــــــد المعـــــــــــــــــــــادلات ))) هو لقب تستحقة عن جدارة بكل تأكيد ولا اجد الا هذا اللفب لكي ارد به عليك ... ولكن لي طلب صغير هل يمكن تتطوير المعادلة لتعمل علي الاسماء المركبة بقا ياراجل كنت عاوز تحرمنا من كل هذه الروائع دي ... حرام عليك استاذنا انت بحق وبالصوت العالي ((( عميــــــــــــــــــد المعـــــــــــــــــــــادلات ))) جزاك الله خيرا