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

مشاركة Sub ClearClipboardAndFreeMemory() ' تحرير محتوى الحافظة On Error Resume Next Dim DataObject As Object Set DataObject = CreateObject("MSForms.DataObject") DataObject.SetText "" DataObject.PutInClipboard Set DataObject = Nothing On Error GoTo 0 ' تحرير الذاكرة DoEvents Application.Echo True, "Memory cleared" End Sub

وعليكم السلام ورحمة الله وبركاته.. في مديول جديد ، الصق الكود التالي :- Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long Sub ClearClipboard() If OpenClipboard(0) Then EmptyClipboard CloseClipboard End If End Sub ويتم الاستدعاء باسم الصب ClearClipboard

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

ما شاء الله لا قوة الا بالله .. اخي فادي ولا اجمل .. سلمت أناملك سبحان الذي منحك الصبر والتمكن.. على هذا العمل الرائع والدقيق الحقيقة هذه الجمل البرمجية الجميلة تدرس وتحفظ كمرجع مهم للغاية لذا تم السطو على كم سطر منها .. فأعتذر .. زادك الله علما انا كنت اعمل على طلب الأخ سلمان وقت طلب مني ذلك ولكني توقفت لمشكلات ظهرت امامي وقد تمت معالجتها بفضل الله الفكرة التي يجب ان يكون تصميم الجداول قائم عليه كالتالي : 1- وجود حقل غير قابل للتكرار في جميع الجداول خاصة الجدول الفرعي الخارجي 2- خصائص العلاقة بين الجدول الرئيس والفرعي ( في القاعدة الحالية لاباس من توالي التحديث والحذف وهو جيد لاختصار عملية الحذف .. اما في القاعدة الخارجية فممنوع ويكفي التكامل فقط) 3- اضافة حقل نعم لا من اجل تأكيد التصدير وايضا الحذف 4- عمل تصفية بين تاريخين لحصر السجلات المراد اجراء العمليات عليها 5- لا يلزم الانتظار لشهر او غيره في عملية الحذف وانما تتم مباشرة بعد الترحيل تم العمل على النحو التالي وهي وجهة نظر تخصني وتحقيقا لما تفضل السائل بتأكيده : ((( وكما ذكرت ان هذه الفواتير خاصه بالزكاة والدخل ولاتحتمل الخطاء ))) لذا : لا يسمح باختيار قاعدة الببانات الخارجية من قبل المستخدم وانما توضع بجانب قاعدة البيانات الاساسية تم الضبط ولا خوف من اي خطأ مقصود او غير مقصود هذا للترحيل والحذف : Dim strPath As String strPath = CurrentProject.Path & "\Zakat2.accdb" DoCmd.SetWarnings False DoCmd.RunSQL "INSERT INTO [;DATABASE=" & strPath & "].TBInvoiceMain2 " & _ "SELECT TBInvoiceMain.* FROM TBInvoiceMain " & _ "WHERE TBInvoiceMain.chekForDel=True" DoCmd.RunSQL "INSERT INTO [;DATABASE=" & strPath & "].TBInvoiceSub2 " & _ "SELECT TBInvoiceSub.* FROM TBInvoiceMain " & _ "INNER JOIN TBInvoiceSub ON TBInvoiceMain.ID = TBInvoiceSub.ID " & _ "WHERE TBInvoiceMain.chekForDel=True" DoCmd.RunSQL "DELETE TBInvoiceMain.*, TBInvoiceMain.chekForDel FROM TBInvoiceMain " & _ "WHERE TBInvoiceMain.chekForDel=True" DoCmd.SetWarnings True وهذا للاسترجاع : lngInvoiceNumber = CLng(Trim(Me.Text1)) DoCmd.SetWarnings False DoCmd.RunSQL "INSERT INTO TBInvoiceMain " & _ "SELECT * FROM [;DATABASE=" & strPath & "].TBInvoiceMain2 " & _ "WHERE InvoiceNumber = " & lngInvoiceNumber DoCmd.RunSQL "INSERT INTO TBInvoiceSub " & _ "SELECT * FROM [;DATABASE=" & strPath & "].TBInvoiceSub2 " & _ "WHERE InvoiceNumber = " & lngInvoiceNumber DoCmd.SetWarnings True MsgBox "تم الاسترجاع", , "" Zakat.rar

ممكن الاستغناء عن إضافة المسارات في الجدول ويتم عرضها من المجلد مباشرة بمعرفة الرقم فقط

اصنع زر في النموذج لديك ثم ادرج هذا الكود فيه ............... Dim db As DAO.Database Dim rs As DAO.Recordset Dim oldPicPath As String Dim newPicPath As String Dim FirstName As String Dim keyVal As String Dim desktopPath As String Dim sourceFolder As String Dim destFolder As String Dim fileSystem As Object desktopPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") sourceFolder = desktopPath & "\555\Pic1\" ' المجلد المصدر destFolder = desktopPath & "\555\Pictures\" ' المجلد الوجهة Set fileSystem = CreateObject("Scripting.FileSystemObject") If Not fileSystem.FolderExists(destFolder) Then fileSystem.CreateFolder destFolder End If Set db = CurrentDb Set rs = db.OpenRecordset("Table1", dbOpenDynaset) Do While Not rs.EOF If IsNull(rs!Pic2) Or rs!Pic2 = "" Then FirstName = rs!FirstName keyVal = rs!Key If Not IsNull(FirstName) And Not IsNull(keyVal) Then oldPicPath = sourceFolder & FirstName & ".jpg" newPicPath = destFolder & keyVal & ".jpg" If fileSystem.FileExists(oldPicPath) Then fileSystem.MoveFile oldPicPath, newPicPath rs.Edit rs!Pic2 = newPicPath rs.Update End If End If End If rs.MoveNext Loop rs.Close Set rs = Nothing Set db = Nothing Set fileSystem = Nothing MsgBox "تم نقل الصور وتحديث الحقل Pic2 بنجاح", vbInformation

وعليكم السلام ورحمة الله وبركاته لاحظ الشرح ثم استخدم هذا ................ Private Sub NEM_SH_NotInList(NewData As String, Response As Integer) Dim db As DAO.Database Dim rs As DAO.Recordset Dim MsgBoxResult As VbMsgBoxResult MsgBoxResult = MsgBox("العنصر '" & NewData & "' غير موجود. هل ترغب في إضافته؟", vbYesNo + vbQuestion, "إضافة عنصر جديد") If MsgBoxResult = vbYes Then Set db = CurrentDb Set rs = db.OpenRecordset("SH", dbOpenDynaset) NewID = Nz(DMax("ID_SH", "SH"), 0) + 1 rs.AddNew rs!ID_SH = NewID rs!ASASE = NewData rs.Update rs.Close Set rs = Nothing Set rs1 = Nothing Set db = Nothing Response = acDataErrAdded Else Response = acDataErrContinue End If End Sub

الدالة لتحويل نتائج دالة التفقيط NoToTxt (لا أعرف كاتبها) إلى أرقام. وقد كتبتها بناءً على طلب أحد أعضاء منتدى الاكسل. Function NoToTxtRev(ByVal TheTxt As String, MyCur As String, MySubCur As String) As Double 'AbuuAhmed, last update 2024/12/30 'Reverse of NoToTxt function Dim Pos As Integer, Step As Byte, Part4 As Integer, Part As Byte Dim i As Byte, ii As Integer Dim Parts(6), a, b, c Dim Text As String Dim Sum4 As Double, Sum As Double Dim Key0, Key1, Key2, Key3 Dim Sp As Integer Dim Pwr As Integer a = Array("", "مائة", "مائتان", "ثلاثمائة", "أربعمائة", "خمسمائة", "ستمائة", "سبعمائة", "ثمانمائة", "تسعمائة", _ "", "عشر", "عشرون", "ثلاثون", "أربعون", "خمسون", "ستون", "سبعون", "ثمانون", "تسعون", _ "", "واحد", "اثنان", "ثلاثة", "أربعة", "خمسة", "ستة", "سبعة", "ثمانية", "تسعة") b = Array("إحدى", "إثنى", "عشرة", "فقط ", "و ", "ملياران", "مليونان", "ألفان", _ "ومليار", "ومليون", "وألف", "فقط مليار", "فقط مليون", "فقط ألف", "فقط ") c = Array("واحد", "اثنان", "صفر عشر", "فقط ", "و", "اثنان مليار", "اثنان مليون", "اثنان ألف", _ "وواحد مليار", "وواحد مليون", "وواحد ألف", "واحد مليار", "واحد مليون", "واحد ألف", "") Key1 = Array("", "مليار", "ملياران", "مليارات") Key2 = Array("", "مليون", "مليونان", "ملايين") Key3 = Array("", "ألف", "ألفان", "آلاف") For i = 0 To UBound(b) TheTxt = Replace(TheTxt, b(i), c(i)) Next i If MyCur & MySubCur <> "" Then Pos = InStr(1, TheTxt, MyCur) If Pos > 0 Then Parts(5) = Replace(Mid(TheTxt, Pos + Len(MyCur)), MySubCur, "") TheTxt = Left(TheTxt, Pos - 1) Else Pos = InStr(1, TheTxt, MySubCur) If Pos > 0 Then Parts(5) = Replace(TheTxt, MySubCur, "") TheTxt = "" End If End If Else Pos = InStr(1, TheTxt, " ") If Pos > 0 Then Parts(5) = Trim(Mid(TheTxt, Pos + 3)) TheTxt = Left(TheTxt, Pos - 1) End If End If For Part = 1 To 3 Key0 = IIf(Part = 1, Key1, IIf(Part = 2, Key2, Key3)) Pos = InStr(1, TheTxt, Key0(1)) If Pos = 0 Then Pos = InStr(1, TheTxt, Key0(2)) If Pos = 0 Then Pos = InStr(1, TheTxt, Key0(3)) If Pos > 0 Then Parts(Part) = Left(TheTxt, Pos - 1) Pos = InStr(Pos, TheTxt & " ", " ") TheTxt = Mid(TheTxt, Pos) End If Next Part Parts(4) = TheTxt For i = 1 To 5 Parts(i) = Trim(Replace(Parts(i), " و", " ")) Parts(i) = Replace(Parts(i), " احد", " واحد") Next i For Part4 = 0 To 12 Step 3 Part = Part4 / 3 + 1 Sum4 = 0 Sp = 3 - (Len(Parts(Part)) - Len(Replace(Parts(Part), " ", ""))) If Sp < 1 Then Sp = 1 For Step = Sp To 3 Pos = InStr(1, Parts(Part) & " ", " ") Text = Trim(Left(Parts(Part), Pos - 1)) Parts(Part) = Mid(Parts(Part), Pos + 1) If Text <> "" Then For i = 1 To UBound(a) Pwr = 10 ^ (3 - Fix((i - 1) / 10) - 1) ii = i Mod 10 If Text = a(i) Then If Part = 5 Then Sum4 = Sum4 + ii * Pwr Else Sum4 = Sum4 + ii * Pwr * Val("1" & IIf(Part = 5, "", String(9 - Part4, "0"))) End If Exit For End If Next i End If Next Step Sum = Sum + IIf(Part = 5, Sum4 / 100, Sum4) Next Part4 NoToTxtRev = Sum End Function

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

بعد اذنك سيد @Foksh ممكن عمل ذلك عن طريق النموذج أو التقرير دون الحاجة لطريقتك هذه

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

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

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

وعليكم السلام ورحمة الله وبركاته .. استخدم في الزر هذا الكود :- Private Sub upx_Click() Dim raten As Double raten = Nz(Me.rxy, 0) If raten = 0 Then MsgBox "Raten يرجى إدخال قيمة صحيحة في مربع النص", vbExclamation, "تنبيه" Me.rxy.SetFocus Exit Sub End If CurrentDb.Execute "UPDATE tbfr SET rx = ratex * " & raten & ", ry = ratey * " & raten, dbFailOnError Me.Requery End Sub استعلام تحديث داخل الزر يقوم بالمطلوب ,,

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

تفضل استاذ @فؤاد الدلوي المرفق حسب ما فهمت . ووافني بالرد . test (1111).rar

مرحبا بكم New Microsoft Excel Worksheet (3).xlsx ارغب بجلب البيانات المسجلة في الشيت ريبورت الى تقرير البحث عندما ادخل التاريخ يجلب لي البيانات

وعليكم السلام ورحمة الله وبركاته أستاذ @سلمان الشهراني ، لي مداخلة بسيطة :- في مثالك لاحظت ان رقم الفاتورة مكرر في سجلات القاعدة الأولى ، هل هذا منطقي أم هو مجرد مثال ؟؟ في حال كان هو فعلاً كذلك ، فعلى أي أساس نريد استرجاع فاتورة محددة قد يكون لها سجلات مكررة بنفس رقم الفاتورة ؟؟؟؟؟ على العموم إليك اقتراحي :- في زر الترحيل الى القاعدة الأولى استخدم الكود التالي :- Private Sub COM1_Click() On Error GoTo ErrorHandler Dim db1 As DAO.Database Dim db2 As DAO.Database Dim rst1 As DAO.Recordset Dim rstCheck As DAO.Recordset Dim strSQL As String Dim strCheck As String Dim strPath2 As String Dim intCount As Integer strPath2 = CurrentProject.Path & "\Zakat2.accdb" Set db1 = CurrentDb Set db2 = DBEngine.OpenDatabase(strPath2) strCheck = "SELECT COUNT(*) AS NewCount " & _ "FROM TBInvoiceMain " & _ "WHERE ID NOT IN " & _ "(SELECT ID FROM [;DATABASE=" & strPath2 & "].TBInvoiceMain2)" Set rstCheck = db1.OpenRecordset(strCheck) If Not rstCheck.EOF Then If rstCheck!NewCount = 0 Then MsgBox "لا توجد فواتير جديدة للترحيل", vbInformation + vbMsgBoxRight, "" GoTo CleanUp End If If MsgBox("سيتم نقل " & rstCheck!NewCount & " فاتورة . هل تريد المتابعة؟", _ vbQuestion + vbMsgBoxRight + vbYesNo, "") = vbNo Then GoTo CleanUp End If End If strSQL = "SELECT DISTINCT TBInvoiceMain.* " & _ "FROM TBInvoiceMain " & _ "WHERE InvoiceNumber NOT IN " & _ "(SELECT InvoiceNumber FROM [;DATABASE=" & strPath2 & "].TBInvoiceMain2)" Set rst1 = db1.OpenRecordset(strSQL) intCount = 0 If Not rst1.EOF Then Do While Not rst1.EOF On Error Resume Next strSQL = "INSERT INTO [;DATABASE=" & strPath2 & "].TBInvoiceMain2 " & _ "SELECT ID, ID2, InvoiceNumber, FormNumber, InvoiceType, UUID, " & _ "InvoiceSerial, InvoiceDate, InvoiceTime, InvoiceTypeCodeID, " & _ "InvoiceTypeCodeName, InvoiceHash, DateSupply, EndDateSupply, " & _ "PaymentMethod, InstructionNote, TotalDiscount, DiscountReason, " & _ "TaxCode, TaxCodeName, TaxPercentage, InvoiceQR, InvoiceXmlName, " & _ "InvoiceXmlFullPath, EncodedInvoice, XMLCreated, SendingStatus, " & _ "ZatcaStatusCode, ZatcaXMLSent, ZatcaWarningMessage, ZatcaErrorMessage, " & _ "ClearedInvoice, BuyerStreetName, BuyerAdditionalStreetName, " & _ "BuyerBuildingNumber, BuyerPlotIdEntification, BuyerCityName, " & _ "BuyerPostalCode, BuyerCountrySubEntity, BuyerCitySubDivisionName, " & _ "BuyerCompanyName, BuyerTaxNumber, clearedXmlFullPath, BuyerCommercialRegistrationNo " & _ "FROM TBInvoiceMain WHERE InvoiceNumber = " & rst1!InvoiceNumber db1.Execute strSQL If Err.Number = 0 Then strSQL = "INSERT INTO [;DATABASE=" & strPath2 & "].TBInvoiceSub2 " & _ "SELECT ID, InvoiceNumber, ItemName, Quantity, ItemPriceBeforeTax, " & _ "TaxPercentage, TaxCode, Discount " & _ "FROM TBInvoiceSub WHERE InvoiceNumber = " & rst1!InvoiceNumber db1.Execute strSQL If Err.Number = 0 Then intCount = intCount + 1 End If End If On Error GoTo ErrorHandler rst1.MoveNext Loop strSQL = "DELETE TBInvoiceSub.* " & _ "FROM TBInvoiceSub INNER JOIN TBInvoiceMain ON TBInvoiceMain.ID = TBInvoiceSub.ID " & _ "WHERE DateDiff('d', TBInvoiceMain.InvoiceDate, Date()) > 30" db1.Execute strSQL strSQL = "DELETE TBInvoiceMain.* " & _ "FROM TBInvoiceMain " & _ "WHERE DateDiff('d', InvoiceDate, Date()) > 30" db1.Execute strSQL If intCount > 0 Then MsgBox "تم ترحيل " & intCount & " فاتورة بنجاح" & vbCrLf & _ "وتم حذف الفواتير الأقدم من 30 يوم", vbInformation + vbMsgBoxRight, "" Else MsgBox "لم يتم ترحيل أي فواتير", vbInformation + vbMsgBoxRight, "" End If End If CleanUp: If Not rst1 Is Nothing Then rst1.Close If Not rstCheck Is Nothing Then rstCheck.Close Set rst1 = Nothing Set rstCheck = Nothing If Not db2 Is Nothing Then db2.Close Set db2 = Nothing Exit Sub ErrorHandler: MsgBox "حدث خطأ أثناء عملية الترحيل", vbCritical + vbMsgBoxRight, "" Resume CleanUp End Sub أما في نموذج استرجاع رقم فاتورة محدد ، استخدم الكود التالي :- Private Sub COM1_Click() On Error GoTo ErrorHandler If IsNull(Me.Text1) Or Trim(Me.Text1) = "" Then MsgBox "الرجاء إدخال رقم الفاتورة المطلوب استرجاعها", vbExclamation + vbMsgBoxRight, "" Me.Text1.SetFocus Exit Sub End If If Not IsNumeric(Me.Text1) Then MsgBox "الرجاء إدخال رقم فاتورة صحيح", vbExclamation + vbMsgBoxRight, "" Me.Text1.SetFocus Exit Sub End If Dim db1 As DAO.Database Dim db2 As DAO.Database Dim rst1 As DAO.Recordset Dim strSQL As String Dim strPath2 As String Dim lngInvoiceNumber As Long strPath2 = CurrentProject.Path & "\Zakat2.accdb" lngInvoiceNumber = CLng(Trim(Me.Text1)) Set db1 = CurrentDb Set db2 = DBEngine.OpenDatabase(strPath2) strSQL = "SELECT COUNT(*) AS InvCount " & _ "FROM [;DATABASE=" & strPath2 & "].TBInvoiceMain2 " & _ "WHERE InvoiceNumber = " & lngInvoiceNumber Set rst1 = db1.OpenRecordset(strSQL) If rst1!InvCount = 0 Then MsgBox "الفاتورة رقم " & lngInvoiceNumber & " غير موجودة في قاعدة البيانات الثانية", vbExclamation + vbMsgBoxRight, "" GoTo CleanUp End If strSQL = "SELECT COUNT(*) AS InvCount FROM TBInvoiceMain " & _ "WHERE InvoiceNumber = " & lngInvoiceNumber Set rst1 = db1.OpenRecordset(strSQL) If rst1!InvCount > 0 Then If MsgBox("الفاتورة موجودة بالفعل في القاعدة الحالية . هل تريد استرجاعها مرة أخرى؟", _ vbQuestion + vbYesNo + vbMsgBoxRight, "") = vbNo Then GoTo CleanUp End If End If strSQL = "INSERT INTO TBInvoiceMain " & _ "SELECT * FROM [;DATABASE=" & strPath2 & "].TBInvoiceMain2 " & _ "WHERE InvoiceNumber = " & lngInvoiceNumber db1.Execute strSQL strSQL = "INSERT INTO TBInvoiceSub " & _ "SELECT * FROM [;DATABASE=" & strPath2 & "].TBInvoiceSub2 " & _ "WHERE InvoiceNumber = " & lngInvoiceNumber db1.Execute strSQL MsgBox "تم استرجاع الفاتورة رقم " & lngInvoiceNumber & " بنجاح", vbInformation + vbMsgBoxRight, "" Me.Text1 = "" Me.Text1.SetFocus CleanUp: If Not rst1 Is Nothing Then rst1.Close Set rst1 = Nothing If Not db2 Is Nothing Then db2.Close Set db2 = Nothing Exit Sub ErrorHandler: MsgBox "حدث خطأ أثناء عملية الاسترجاع", vbCritical + vbMsgBoxRight, "" Resume CleanUp End Sub تم الإعتماد هنا على رقم الفاتورة من الحقل InvoiceNumber ، وأخبرني بالنتيجة . المرفق بعد التعديل .. Zakat.zip .

زر طباعة لاى صورة من خلال الفورم بالاكسل بالذكاء الاصطناعي وتعلم كيفية الكتابة بالكوفي في ملف الاكسل الفيديو فورم ايات قرانية.xlsm

أظن أنه يمكننا إضافة شرط التحقق من كلمة المرور عند محاولة غلق الحسابات في الكود بحيث لا يمكن لأي شخص تنفيذه إلا إذا كان يعرف كلمة المرور الصحيحة هذا يضيف طبقة أمان إضافية للحماية ويضمن أن الشخص الذي يقوم بالعملية هو الشخص المخول فقط جرب هدا التعديل Option Explicit Private Const Clé As String = "1234" Public Property Get WS() As Worksheet Set WS = Sheets("Sheet1") End Property Sub ProtectSheet(xligne As Long) With WS .Unprotect Password:=Clé: .Cells.Locked = False .Range("A2:M" & xligne).FormulaHidden = True .Range("A2:M" & xligne).Locked = True: .Protect Password:=Clé End With End Sub Sub WSUnprotect() With WS .Unprotect Password:=Clé .Cells.Locked = False .Cells.FormulaHidden = False End With End Sub Sub Data_Protection() Dim xligne As Long If InputBox("أدخل كلمة المرور للمتابعة") <> Clé Then MsgBox "كلمة المرور غير صحيحة تم إلغاء العملية", vbCritical Exit Sub End If xligne = Application.InputBox("أدخل رقم الصف الأخير لقفل الخلايا", Type:=1) If xligne < 1 Or xligne > WS.Rows.Count Then MsgBox "خطأ في الإدخال يرجى إدخال رقم صف صحيح", vbExclamation Exit Sub End If SetApp False ProtectSheet xligne SetApp True MsgBox "تم قفل الحسابات بنجاح لغاية الصف: " & xligne, vbInformation End Sub Sub Data_UnProtection() Dim PassProtect As String PassProtect = InputBox("أدخل كلمة المرور لفك الحماية") If PassProtect = Clé Then SetApp False: WSUnprotect: SetApp True MsgBox "تم فتح جميع الحسابات بنجاح", vbInformation ElseIf PassProtect <> "" Then MsgBox "كلمة المرور غير صحيحة", vbCritical End If End Sub Private Sub SetApp(ByVal enable As Boolean) On Error GoTo xError Application.ScreenUpdating = enable Application.EnableEvents = enable Application.Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual) Exit Sub xError: End Sub غلق المدى المحدد .xlsb

جزاكم الله خيرا وبارك فيكم