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

وعليكم السلام 🙂 حيا الله اخوي عبد اللطيف 🙂 تفضل: . ثم . بهذا الكود : Option Compare Database Private Sub cmd_Hide_Show_Click() If Me.cmd_Hide_Show.Caption = "اخفاء" Then Call Hide Me.cmd_Hide_Show.Caption = "اظهار" Else Call Show Me.cmd_Hide_Show.Caption = "اخفاء" End If End Sub Private Sub Hide() Me.x1.Visible = False Me.x2.Visible = False Me.x3.Visible = False End Sub Private Sub Show() Me.x1.Visible = True Me.x2.Visible = True Me.x3.Visible = True End Sub جعفر 1144.hide_show.accdb.zip

تفضل-يمكنك استخدام هذه المعادلة =INDEX($D$3:$D$250,MATCH($F3,$B$3:$B$250,0)*MATCH($G3,A$3:$A$250,0)) 1إستخراج بيانات.xlsx

وعليكم السلام-تفضل لك ما طلبت Option Explicit Dim listRng As Range Private Sub btnRemove_Click() Dim i As Long Dim rowsList As String For i = ListBox1.ListCount - 1 To 0 Step -1 If ListBox1.Selected(i) Then ListBox1.RemoveItem i Else rowsList = rowsList & i + 1 & " " End If Next i If rowsList <> "" Then UpdateListRange Left(rowsList, Len(rowsList) - 1) End Sub Sub UpdateListRange (rowsList As String) Dim addr As String Dim iRow As Variant Dim rowsListArr As Variant rowsListArr = Split(rowsList) For iRow = UBound(rowsListArr) To LBound(rowsListArr) Step -1 addr = addr & listRng(rowsListArr(iRow)).address(False, False) & "," Next iRow If addr <> "" Then addr = Left(addr, Len(addr) - 1) Set listRng = listRng.Parent.Range(addr) End Sub Private Sub UserForm_Initialize() With Worksheets("Sheet1").Range("A2:E1000") Me.ListBox1.List = Application.Transpose(.Cells) '<-- fill ListBox1 list Set listRng = .Cells End With End Sub طريقة تصميم فورم بحث عن طريق لست بوكس5.xls

تفضل بعد اذن الأستاذ حسين 1مصغر.xlsm

حياك الله 🙂 واذا ما اردنا ان نكتب عربي في الكود ، فنستفيد من اعدادات الحقل ونحفظ القيمة هناك في tag الحقل ، هكذا : . والكود يصبح (طبعا الكلمات بالعربي للتوضيح فقط ، ويمكنك حذفها من الكود) : Private Sub cmd_Hide_Show_Click() Dim x() As String 'اعمل هذه القيمة في مصفوفة : اخفاء,اظهار 'والفارزة بين الكلمات عبارة عن فاصلة x = Split(Me.cmd_Hide_Show.Tag, ",") 'x(0) = اول قيمة في المصفوفة ، وهي اخفاء 'x(1) = ثاني قيمة في المصفوفة ، وهي اظهار If Me.cmd_Hide_Show.Caption = x(0) Then Call Hide Me.cmd_Hide_Show.Caption = x(1) Else Call Show Me.cmd_Hide_Show.Caption = x(0) End If End Sub جعفر 1144.1.hide_show.accdb.zip

وهنا

السلام عليكم ورحمة الله وبركاته أسأل الله تعالى أن يجعله بميزان حسناتكم آمين جزاكم الله خيراً

تفضل لك ما طلبت-طبعا بعد اذن استاذ ابو ايسل الاجازة.xlsx

جرب المرفق لعل فيه بعض ما تريد... EX.xlsx

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

وعليكم السلام 🙂 بياناتك افقية بهذه الطريقة: . وتم تحويلها عموديا الى جعفر 1142.قاعدة البيانات1.accdb.zip

السلام عليكم ,,, الرجاء مراجعه الملف وارجو ان تجد به ما طلبت اخي الكريم ... العمال.xlsx

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

وكيف تنتظر وتتم المساعدة بدون ملف ؟ّ!!! لا يمكن المساعدة الا بعد رفع ملف مدعوم بشرح كافى عن المطلوب-والا ستحذف المشاركة ,لأننا نبهنا اكثر من مرة لا يجوز رفع اى مشاركة بدون ملف

نعم وهو الملف الوسيط سيتكفل بهذه المهمة تم التعديل المطلوب ولتسهيل الأمر على مسؤول القاعدة اذا اراد مثلا اظهار الكائنات للتعديل أو الإطلاع تمت اضافة زر أمر لاظهار الكا ئنات وشريط الادوات بدل ما يقوم بألغاء كلمة السر ثم اعادة تفعيل الشفت وفتح القاعدة من جديد فقط نقرة زر كل شي يكون أمامه طبعا زر الأمر لازم يكون مخفي عن المستخدم ونقوم بإيجاد طريقة لاظهاره للمسؤول بالنسبةلي بما اني استخدم نظام صلاحيات مستخدمين أضع هذا الكود عند فتح النموذج لاظهار زر الأمر وتفعيله If MyUser.username() = "Kaser906" Then Me![cmd47].Enabled = True Me![cmd47].Visible = True End If الملف بالمرفقات ::بالتوفيق:: إذا كنت ترى هذه المشاركة مفيدة فلا تنسى التقييم FreeKaser906.rar

أستاذ dragon2007 اين الضغط على الإعجاب ؟!!

جرب المرفق التقرير بامكانك تنسيق وفقا لما تريد مع رجاء التقيد بنظام الموقع سؤال واحد لكل موضوع لا نرغب مخالف قوانين الموقع Database1.mdb

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

السلام عليكم ورحمه الله وبركاته اخوانى الافاضل فى بعض الاحيان نحتاج اضافه بيانات وعرض البيانات فالنموذج مع عدم السماح بالتعديل فالبيانات السابقه يمكن عمل ذلك فى حاله عرض البيانات فقط من خلال عرض النموذج فى وضع التصميم وتحديد الحقول بالكامل مره واحده ومن الخصائص نقوم بتحديد خاصيه تم تأمينه ونحدد لها نعم كما بالصوره ولاكن اذا اردنا عرض البيانات السابقه مع عدم التعديل عليها والسماح بالاضافه فالكود التالى يفى بالغرض باذن الله احاول ان اتعلم واشارككم مع اصل اليه من معلومات للتصحيح ولاستفاده والاستذاده من اساتذتى وجميع الاخوان فى منتدانا الغالى ومرفق مثال : نموذج tblNames ارجو ان اكون قد وفقت فى الشرح وايصال المعلومه وارجو من اساتذتنا التعقيب والاضافه ' كود لعدم السماح بتعديل البيانات السابقه والسماح بالاضافه فقط If Not Me.NewRecord Then Me.AllowEdits = False End If وجزاهم الله خيرا كل من وضع لنا معلومه وعلمنا وشاركنا وساعدنا واسال الله لهم ان يكتب لهم بكل حرف حسنه وان يرزقهم ويبارك لهم فى جميع ما يحبون وان يرزقهم الفردوس الاعلى تقبل الله منا ومنك صالح الاعمال تحياتى لكم طبتم واهتديتم test.accdb

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

جرب الان Database1.mdb

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

العفو اخي الشكر لله سبحانه

أستاذ maiami أين الضغط على الإعجاب ؟

تحتاج تستورد الوحدة النمطية الموجودة بالملف وفي القيمة الافتراضية لحقل التاريخ الهجري تضع الاتي =strHijri(Date())

انظر هذه طريقة سريعة على الماشي .... والصبر جميل ....... المدارس.accdb

حسب فهمي أنظر إن كان هذا يلبي رغبتك ::بالتوفيق:: إن كنت ترى هذه المشاركة مفيده فلا تنسى التقييم Utilities Hide Ico Minimze To SysTray V.02.906.rar

طبعا بعد اذن اخي سليم حاصبيا من format cells ثم Custom ثم ضع هذا التنسيق

جرب الملف تحياتي جدول1.xlsx

تم اضافه الملف في المشاركه السابقه مع الشرح قم بتحميله مره اخري

السلام عليكم 🙂 شكرا اخي كاسر ، فلقد تذكرت اني مررت بمثل هذه المشكلة ، ودخت الى ان عرفت المشكلة 🙂 لما تستخدم الاكسس 2007 فما فوق ، فالاكسس يحمي الكمبيوتر ولا يسمح لك ان تفتح اي برنامج ، اذا اردت فتح البرنامج في مجلد "غير موثوق به" ، لذا ، اذا فتحت البرنامج في مجلد غير موثوق به ، سيظهر لك هذا الخط الاصفر ، وبه زر "تمكين المحتوى" : . لذا عليك بضغط الزر ، وسيعمل الكود في برنامجك بطريقة عادية. ولكن ، وحتى لا تحصل على هذه الرسائل دائما ، يجب عليك ان تعمل مجلد/مجلدات موثوق بها : ويجب ان تتأكد من انك سمحت للاكسس ان يعطيك الخط الاصفر : بعد هذا ، المفروض ان برنامجك يشتغل عدل 🙂 ولكن ، هناك مشكلة يقوم بها الكثير من المبرمجين ، وهذه المشكلة في جعل النموذج: منبثق = نعم ، شكلي او مشروط = نعم ، ويجعل النموذج ينفتح على حجم الشاشة (docmd.maximize) : . فلما ينفتح البرنامج ، سيكون الخط الاصفر خلف النموذج ، فلن تراه ، وعليه لن يعمل البرنامج !! جعفر

السلام عليكم -فقط يمكنك استخدام هذه المعادلة =IF(B1*11.5%>316.25,316.25,B1*11.5%)

جرب هذه الداله بعد اذن أ/ سليم Boook1.xlsx

وعليكم السلام-تفضل =CONCATENATE(E4," ",E5," ",E6," ",E7," ",E8," ",E9," ",E10," ",E11)

اي جدول في الاكسل يجب الا يكون فيه خلايا مدمجة تم اضافة سطر فارغ رقم 2 لازالة الدمج Option Explicit Sub TWO_IN_ONE() Dim RD As Range, RK As Range Range("M2").CurrentRegion.Clear Set RD = Range("d3").CurrentRegion.Columns(3) Set RK = Range("K3").CurrentRegion.Columns(3) With Range("M2").Resize(RD.Rows.Count) .Value = RD.Value .Offset(RD.Rows.Count).Resize(RK.Rows.Count) = _ RK.Value End With With Range("M2").CurrentRegion .Sort Range("M2"): .Interior.ColorIndex = 6 .Borders.LineStyle = 1: .Font.Bold = True End With End Sub الملف مرفق COPY_2 iN 1.xlsm

ذكرتني بأحد مشاريعي من زماااان ، لا كان عندي يوم ولا ليل ، كله كان شغل والحمدلله خلص الشغل بعدما خلصت روحي 🙂 اعتبر برنامجك Proof of Concept ، ولا اروع ، ونادرا ما اشوف مثله 🙂 اخي الفاضل ابو إبراهيم ، ابدعت واجدت ، في طريقة جلب البيانات وترتيبها ، وبالاخص في عرضها 🙂 صدقني كنت اشوف الكود وانا مستمتع ، ولو اني لم اتتبعه بحذافيره ، ولكنه بالفعل عمل جبار ونادر 🙂 يشرفني ان اكون معاكم في هذا الفريق 🙂 جعفر

السلام عليكم ورحمة الله أحببت أن أشارك معكم في بخصوص هذا الموضوع بطريقة مختلفة بعض الشيء.. أرجو أن تجدوا فيها شيئا جديدا :: تنبيهات --- يتم رسم التقرير برمجيا.. --- عدد السجلات في رأس التقرير ثابتة من ناحية التصميم، متغيرة من ناحية البيانات.. - يتم تفيير البيانات في هذا المقطع وفقا لكميات البيانات.. - تستطيع كمية البيانات في هذا المقطع زيادة عدد صفحات التقرير تناسبا مع مصدر بيانات التقرير.ز - عدد السجلات المعروضة في هذا المقطع (10) سجلات لكل صفحة --- مصدر البيانات الأساسي هو الاستعلام (QRY_MATERIAL) --- يعاد بناء هذا الاستعلام كاستعلام (توحيد) بناءً على الفرضيتين التاليتين: -- التوحيد من أجل تكملة العشرة.. -- يتم إخفاء السجلات الوهمية بفحص معطيات الحقل الوهمي (TEST) - تزيد قيمة هذا الحقل كلما زادت الاستعلامات الوهمية (...،0،1،2) - البيانات الحقيقة تأخذ القيمة (0) --- إذا كانت بيانات مقطع الرأس أكبر من بيانات مصدر البيانات الأساسي -- يزيد عدد الاستعلامات الوهممية بواقع استعلام لكل (10) سجلات لزيادة عدد الصفحات -- يتم احتساب عدد الاستعلامات وتضمينها برمجيا بواسطة الإجراء (UNION_SQL) أرجو ألا تبخلوا بالنقد والتعليق😁 MATRIX REPORT.accdb

ارى ان يتم اضافة عمود مساعد في صفحة البيانات لتكويد الفواتير مثلا مشتريات S ومبيعات M واضافة ComboBox في الفورم يضاف له فاتورة مشتريات و فاتورة مبيعات في حال الاختيار فاتورة مشتريات يرحل في العمود المساعد S وفي حال الاختيار مبيعات يرحل في العمود المساعد S اذا لديك اقتراح اخر ضيفه ليتم العمل على ملفك

بارك الله فيك

وعليكم السلام عليك بلصق هذه الأكواد فى حدث This Workbook Private Sub Workbook_BeforeClose(Cancel As Boolean) MsgBox "مع السلامة " & Application.UserName & _ vbNewLine & "فى حفظ الله شرفتنا", _ vbInformation, "منتدى أوفيسنا" ThisWorkbook.Save Application.Quit End Sub Private Sub Workbook_Open() MsgBox "أهلا وسهلا يا " & Application.UserName & _ vbNewLine & "أتمنى أن تكون فى أفضل حال", _ vbInformation, "منتدى أوفيسنا" End Sub

وعليكم السلام وذلك بدون برامج عن طريق الدخول الى هذه المواقع وتتبع الخطوات بها ومنها : https://smallpdf.com/ar/pdf-to-excel https://www.pdftoexcel.com/ar https://www.almrsal.com/post/514387 https://convertio.co/ar/pdf-xlsx/ https://www.freepdfconvert.com/ar/pdf-to-excel

ملفك كبير جدا من الأفضل العمل على شيت الإكسيل نفسه وليس على يوزرفورم بارك الله فيك تفضل البرنامج.xlsm

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

اهلا بك اخ كريم بالمنتدى كان عليك رفع الملف ولكن تفضل هذا كود للتفقيط Option Explicit Public Const vArabic As Byte = 1 Public Const vEnglish As Byte = 2 Public Const vMale As Byte = 0 Public Const vFemale As Byte = 1 Function Delete(S As String, Index, Count As Integer) As String Delete = Left(S, Index - 1) + _ Mid(S, Index + Count, Len(S)) End Function Function Insert(Source, S As String, Index As Integer) As String Dim LPart, RPart As String LPart = Left(S, Index - 1) RPart = Mid(S, Index, Len(S)) Insert = LPart & Source & RPart End Function Function AddAnd(S1, S2, S3, And_ As String, Lang As Byte) As String Dim InAnd_, 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 Function S2Double(Single_ As Variant, Sex As Byte) As String Dim LLeter As Integer Dim K As Byte Dim Sngl_1, 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 Function Fmale(Num, 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 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 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 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 Function EHunds(Num As Byte, ESingle()) As String EHunds = ESingle(Num) + " hundred" End Function Function ReFormat(InNum As Double, Dec As Byte) As Double Dim NewFormat As String If Dec > 0 Then NewFormat = "0." Else NewFormat = "0" NewFormat = NewFormat & String(Dec, "0") ReFormat = Format(InNum, NewFormat) End Function Function ReStr(InNum As String) As String Dim K, Digits As Byte Dim Num_ As String Num_ = LTrim(InNum) K = InStr(1, Num_, "E+", 1) If K > 0 Then Digits = Val(Mid(Num_, K + 2, 3)) Num_ = Left(Num_, K - 1) Num_ = Delete(Num_, 2, 1) Do While Len(Num_) - 1 < Digits Num_ = Insert(Num_, "0", 1) Loop End If ReStr = Num_ End Function Function AOnly(Num_, FracS, Single_, Ploral_ As String, Parts, Sex, Dec As Byte) As String Const And_ As String * 1 = "æ" Const Lang = vArabic Dim PartNum(0 To 5) As Long Dim Result1(0 To 5) As String Dim N1, N2, N3, TempI, Sex2, K As Byte Dim Only_ As String Dim OnlyPart As String Dim N1_, N2_ As String Dim N3_ As String Dim Part_ As String Dim TempS As String Dim Sngl_1, Sngl_2 As String Dim Female(1 To 10) As Variant Dim Parts_(0 To 11) 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) = "ßÏÑáíæäÇÊ" 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 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) + 6) 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 '{------------------------------------------} N1_ = AddAnd(Result1(0), Result1(1), Result1(2), And_, Lang) N2_ = AddAnd(Result1(3), Result1(4), Result1(5), And_, Lang) Only_ = AddAnd(N1_, N2_, "", And_, Lang) 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_, Ploral_, Sngl_2, "", Lang) Else Only_ = AddAnd(Only_, Ploral_, Sngl_2 & "É", "", Lang) End If Else Only_ = AddAnd(Only_, Ploral_, "", "", 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 Function EOnly(Num_, FracS, Single_ As String, Parts, Dec As Byte) As String Const Lang = vEnglish Dim ESingle(1 To 12) As Variant Dim ETens(2 To 9) As Variant Dim EParts_(0 To 5) As String Dim TempS As String Dim N1, N2, N3, TempI, Sex2 As Byte Dim N1_, N2_, N3_ As String Dim OnlyPart, Part_, Only_ As String Dim Leng, K As Integer Dim PartNum(0 To 5) As Long Dim Result1(0 To 5) As String If Val(Num_) = 0 Then If FracS = "" Then EOnly = LTrim(Single_ & " zero") Else EOnly = Single_ & " " & FracS End If Exit Function End If ESingle(1) = "one" ESingle(2) = "two" ESingle(3) = "three" ESingle(4) = "four" ESingle(5) = "five" ESingle(6) = "six" ESingle(7) = "seven" ESingle(8) = "eight" ESingle(9) = "nine" ESingle(10) = "ten" ESingle(11) = "eleven" ESingle(12) = "twelve" ETens(2) = "twenty" ETens(3) = "thirty" ETens(4) = "forty" ETens(5) = "fifty" ETens(6) = "sixty" ETens(7) = "seventy" ETens(8) = "eighty" ETens(9) = "ninety" EParts_(0) = "" EParts_(1) = "thousund" EParts_(2) = "million" EParts_(3) = "billion" EParts_(4) = "trillion" EParts_(5) = "quadrillion" For K = 0 To Parts - 1 PartNum(K) = Val(Mid(Num_, (K * 3) + 1, 3)) Next K For K = 0 To (Parts - 1) 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_ = EHunds(CByte(N1), ESingle()) Select Case TempI Case 1 To 12: N3_ = ESingle(TempI) Case 13 To 19: If N3 > 0 Then N3_ = Tenteen(CByte(TempI), ETens()) Case 20 To 99: N2_ = ETens(N2) If N3 > 0 Then N3_ = N2_ + "-" + ESingle(N3) N2_ = "" End If End Select OnlyPart = AddAnd(N1_, N2_, N3_, "", Lang) '{------------------------------------------} Part_ = "" If PartNum(K) > 0 Then Part_ = EParts_(Parts - K - 1) If Part_ <> "" Then Part_ = EParts_((Parts - K - 1)) End If Result1(K) = AddAnd(OnlyPart, Part_, "", "", Lang) Next K '{------------------------------------------} N1_ = AddAnd(Result1(0), Result1(1), Result1(2), "", Lang) N2_ = AddAnd(Result1(3), Result1(4), Result1(5), "", Lang) Only_ = AddAnd(N1_, N2_, "", "", Lang) Leng = Len(Only_) Only_ = AddAnd(Only_, FracS, "", " and", Lang) If Only_ <> "" Then Only_ = AddAnd(Single_, Only_, "", "", Lang) EOnly = Only_ End If End Function Function S_Only(InNum As Variant, Lang, FracType As Byte) As Variant Dim Num_ As String Dim K, Dec As Byte Dim FType As Byte If IsNull(InNum) Then S_Only = Null Exit Function End If Num_ = Str(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 Function B_Only(InNum As Variant, Lang, Sex, Dec As Byte, Single_, Ploral_ As String, _ FSex As Byte, SFrac, PFrac As String, FracType As Byte) As Variant Dim Leng, Parts, K As Byte Dim FracVal As Double Dim Num_ As String Dim FracS As String Dim FracNum As String Dim Only As String If IsNull(InNum) Then B_Only = Null Exit Function End If Num_ = Str(InNum) If InStr(1, Num_, "E+", 1) > 0 Then Num_ = ReStr(Num_) FracVal = 0 GoTo DoProcess End If Num_ = ReFormat(Val(InNum), Dec) K = InStr(1, Num_, ".", 1) If K > 0 Then FracS = "0" & Mid(Num_, K, Dec + 1) Else FracS = "" FracVal = Val(FracS) Num_ = Trim(Str(Fix(InNum))) 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") & "/" & Format(FracNum, String(Dec, "0")) Case vEnglish: FracS = Format(FracNum, String(Dec, "0")) & "/" & "1" & String(Dec, "0") End Select Case 3 FracS = FracNum & " " & SFrac If Lang = vEnglish And CDbl(FracNum) > 1 Then FracS = FracS & "'s" 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) Case vEnglish: FracS = EOnly(FracNum, "", "", Parts, 0) & " " & SFrac If CDbl(FracNum) > 1 Then FracS = FracS & "'s" End Select End Select End If Leng = Len(Num_) Parts = Fix((Leng + 2) / 3) For K = 1 To (Parts * 3) - Leng Num_ = Insert("0", Num_, 1) Next K If Len(Num_) > 18 Then B_Only = InNum Exit Function End If Select Case FracType Case 1, 2 Select Case Lang Case vArabic: Only = AOnly(Num_, FracS, Single_, Ploral_, Parts, Sex, Dec) Case vEnglish: Only = EOnly(Num_, FracS, Single_ & "", Parts, Dec) End Select Case 3, 4 Select Case Lang Case vArabic: Only = AOnly(Num_, "", Single_, Ploral_, Parts, Sex, Dec) If CDbl(Num_) = 0 And FracS <> "" Then Only = "" If FracS <> "" Then Only = AddAnd(Only, FracS, "", "æ ", CByte(Lang)) Case vEnglish: Only = EOnly(Num_, "", Single_ & "", Parts, Dec) If CDbl(Num_) = 0 And FracS <> "" Then Only = "" 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 Case vEnglish: B_Only = Only & " only" End Select End If End Function وعليك بوضع هذه المعادلة فى الخلية التى تريد اظهار التفقيط بها بمعنى لو افترضنا ان الرقم موجود بالخلية A2 تكون المعادلة كالتالى : =B_Only(A2,1,0,2,"ريال ","ريالات",0,"فلس","فلسات",4)

اهلا بك اخ كريم فى المنتدى عليك بضبط اللغة العربية لديك كما بالصور :بالدخول على لوحة التحكم Control Panel

وعليكم السلام تفضل هشام.xlsm

وعليكم السلام يمكنك تجربة هذه البرامج Passware kit Forensic.V13.5.855 والأخر Reset VBA Password

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

السلام عليكم اخي ياسر فتحي اشكرك على مرورك العطر ولك مثل دعائك اضعاف مضاعفه ان شاء الله الاخ والاستاذ ياسر خليل اليك المرفق ان شاء الله ان تم حل اشكاليته Kh_Srech_Al_###.rar

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