Ali Mohamed Ali

وعليكم السلام تفضل هذا الكود Function NoToTxt2(TheNo As Double, MyCur As String, MySubCur As String) As String Dim MyArry2(0 To 9) As String Dim MyArry3(0 To 9) As String Dim Myno As String Dim GetNo As String Dim RdNo As String Dim My100 As String Dim My10 As String Dim My1 As String Dim My11 As String Dim My12 As String Dim GetTxt As String Dim Mybillion As String Dim MyMillion As String Dim MyThou As String Dim MyHun As String Dim MyFraction As String Dim MyAnd As String Dim I As Integer Dim ReMark As String If TheNo > 999999999999.999 Then Exit Function If TheNo < 0 Then TheNo = TheNo * -1 ReMark = "لم يتبقي " Else ReMark = "فقط " End If If TheNo = 0 Then NoToTxt2 = "صفر" Exit Function End If MyAnd = " و" MyArry1(0) = "" MyArry1(1) = "مائة" MyArry1(2) = "مائتان" MyArry1(3) = "ثلاثمائة" MyArry1(4) = "اربعمائة" MyArry1(5) = "خمسمائة" MyArry1(6) = "ستمائة" MyArry1(7) = "سبعمائة" MyArry1(8) = "ثمانمائة" MyArry1(9) = "تسعمائة" MyArry2(0) = "" MyArry2(1) = " عشر" MyArry2(2) = "عشرون" MyArry2(3) = "ثلاثون" MyArry2(4) = "اربعون" MyArry2(5) = "خمسون" MyArry2(6) = "ستون" MyArry2(7) = "سبعون" MyArry2(8) = "ثمانون" MyArry2(9) = "تسعون" MyArry3(0) = "" MyArry3(1) = "احدي" MyArry3(2) = "اثنان" MyArry3(3) = "ثلاثة" MyArry3(4) = "اربعة" MyArry3(5) = "خمسة" MyArry3(6) = "ستة" MyArry3(7) = "سبعة" MyArry3(8) = "ثمانية" MyArry3(9) = "تسعة" '====================== GetNo = Round(TheNo, 3) GetNo = Format(TheNo, "000000000000.000") I = 0 '=============== Do While I < 16 If I < 12 Then Myno = Mid$(GetNo, I + 1, 3) Else Myno = Mid$(GetNo, I + 2, 3) + "0" ' "0" + Mid$(GetNo, I + 2, 2) End If If (Mid$(Myno, 1, 3)) > 0 Then RdNo = Mid$(Myno, 1, 1) My100 = MyArry1(RdNo) RdNo = Mid$(Myno, 3, 1) My1 = MyArry3(RdNo) RdNo = Mid$(Myno, 2, 1) My10 = MyArry2(RdNo) If Mid$(Myno, 2, 2) = 11 Then My11 = "احدي عشر" If Mid$(Myno, 2, 2) = 12 Then My12 = "اثني عشر" If Mid$(Myno, 2, 2) = 10 Then My10 = "عشرة" If ((Mid$(Myno, 1, 1)) > 0) And ((Mid$(Myno, 2, 2)) > 0) Then My100 = My100 + MyAnd If ((Mid$(Myno, 3, 1)) > 0) And ((Mid$(Myno, 2, 1)) > 1) Then My1 = My1 + MyAnd GetTxt = My100 + My1 + My10 If ((Mid$(Myno, 3, 1)) = 1) And ((Mid$(Myno, 2, 1)) = 1) Then GetTxt = My100 + My11 If ((Mid$(Myno, 1, 1)) = 0) Then GetTxt = My11 End If If ((Mid$(Myno, 3, 1)) = 2) And ((Mid$(Myno, 2, 1)) = 1) Then GetTxt = My100 + My12 If ((Mid$(Myno, 1, 1)) = 0) Then GetTxt = My12 End If If (I = 0) And (GetTxt <> "") Then If ((Mid$(Myno, 1, 3)) > 10) Then Mybillion = GetTxt + " مليار" Else Mybillion = GetTxt + " مليارات" If ((Mid$(Myno, 1, 3)) = 2) Then Mybillion = " مليار" If ((Mid$(Myno, 1, 3)) = 2) Then Mybillion = " ملياران" End If End If If (I = 3) And (GetTxt <> "") Then If ((Mid$(Myno, 1, 3)) > 10) Then MyMillion = GetTxt + " مليون" Else MyMillion = GetTxt + " ملايين" If ((Mid$(Myno, 1, 3)) = 1) Then MyMillion = " مليون" If ((Mid$(Myno, 1, 3)) = 2) Then MyMillion = " مليونان" End If End If If (I = 6) And (GetTxt <> "") Then If ((Mid$(Myno, 1, 3)) > 10) Then MyThou = GetTxt + " الف" Else MyThou = GetTxt + " الاف" If ((Mid$(Myno, 3, 1)) = 1) Then MyThou = " الف" If ((Mid$(Myno, 3, 1)) = 2) Then MyThou = " الفان" End If End If If (I = 9) And (GetTxt <> "") Then MyHun = GetTxt If (I = 12) And (GetTxt <> "") Then MyFraction = GetTxt End If I = I + 3 Loop '============================ If (Mybillion <> "") Then If (MyMillion <> "") Or (MyThou <> "") Or (MyHun <> "") Then Mybillion = Mybillion + MyAnd End If If (MyMillion <> "") Then If (MyThou <> "") Or (MyHun <> "") Then MyMillion = MyMillion + MyAnd End If If (MyThou <> "") Then If (MyHun <> "") Then MyThou = MyThou + MyAnd End If If MyFraction <> "" Then If (Mybillion <> "") Or (MyMillion <> "") Or (MyThou <> "") Or (MyHun <> "") Then NoToTxt2 = ReMark + Mybillion + MyMillion + MyThou + MyHun + " " + MyCur + MyAnd + MyFraction + " " + MySubCur Else NoToTxt2 = ReMark + MyFraction + " " + MySubCur End If Else NoToTxt2 = ReMark + Mybillion + MyMillion + MyThou + MyHun + " " + MyCur End If End Function

وعليكم السلام يمكنك وضع هذا الكود فى حدث الورقة المراد حماية المعادلات بها Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.HasFormula Then MsgBox "ÇáãÚÇÏáÇÊ áä ÊÙåÑ" 'ActiveSheet.Protect Else 'ActiveSheet.Unprotect End If MyPassword = "123" For Each MySheet In ActiveWorkbook.Sheets MySheet.Protect _ Password:=MyPassword, _ DrawingObjects:=True, _ Contents:=True, _ Scenarios:=True, _ AllowFormattingCells:=True, AllowFormattingColumns:=True, _ AllowFormattingRows:=True, AllowInsertingColumns:=True, AllowInsertingRows _ :=True, AllowInsertingHyperlinks:=True, AllowDeletingColumns:=True, _ AllowDeletingRows:=True, AllowSorting:=True, AllowFiltering:=True, _ AllowUsingPivotTables:=True, _ UserInterfaceOnly:=False Next MySheet End Sub

تفضل تعديل على الكود - الترحيل على اساس شروط ثلاث -استثناء بعض الارقام2.xlsm

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

بعد اذن استاذى الكريم سليم تفضل sales.xlsx

وعليكم السلام لك ما طلبت تعديل على الكود - الترحيل على اساس شروط ثلاث.xlsm

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

تفضل لتحليل الاختبارات للمرحلة المتوسطة والثانوية.xls

اشرح ما تريده بالضبط على الملف مع الإستعانة بالصور للتوضيح

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

بعد اذن استاذنا عماد وذلك بكتابة السطر الأول داخل الخلية ثم الضغط على Alt+Enter وكتابة السطر الثانى جزاك الله كل خير

وذلك بجعل التنسيق كما بالصورة بارك الله فيك

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

بارك الله فيك ولك بمثل ما دعوت لى وزيادة-والحمد لله الذى بنعمته تتم الصالحات

تفضل كميات1.xlsx

اهلا بك اخى الكريم فى المنتدى تفضل هذا الملف لعله يفيدك تعبئة الكومبوبوكس بأسماء أوراق العمل Fill ComboBox With Sheets Names .xlsm

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

يمكنك فعل هذا أولا بدون اكواد بتتبع الشرح فى هذا الرابط : https://academy.hsoub.com/apps/productivity/office/microsoft-excel/حماية-ملفات-microsoft-excel-من-التعديل-بكلمات-سر-r62/ او بوضع هذا الكود لحماية كل اوراق العمل Sub Protect() Dim ws As Worksheet Dim pwd As String pwd = "" ' Put your password here For Each ws In Worksheets ws.Protect Password:=123, UserInterfaceOnly:=True Next ws End Sub وكود اخر لفك الحماية Sub UnProtect() Dim ws As Worksheet Dim pwd As String pwd = "" ' Put your password here For Each ws In Worksheets ws.UnProtect Password:=123 Next ws End Sub بارك الله فيك

تفضل لك ما طلبت عذرا كميات1.xlsx

تفضل كميات1.xlsx

أهلا بك اخ كريم فى المنتدى وان شاء الله بالتوفيق تفضل لعله يكون مفيد بالنسبة لك https://www.officena.net/ib/topic/72392-افضل-برنامج-صيدليات-فارماكير/?tab=comments#comment-467904

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

تفضل 4.xlsm

يمكنك وضع هذا الكود فى موديول جديد وتحديد به مكان واسم الملف المراد فتحه واستدعائه Sub Open_ExistingWorkbook() Workbooks.Open "C:\WorkbookName.xls" End Sub

تفضل انظر الى الصورة