غلاق خلية او صفوف ضمن مدى معين

[Mharee Accounting Albaig]

السلام عليكم 

تحية لجميع الأعضاء الكرام 

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

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

بينا من الصف 3451 تكون متفوحة واعمل بصورة طبيعية  وعندما ادققها وانهي العمل بها الحقها مع باقي الخلايا والصفوف بالاغلاق 

اتمنى ان اكون وصلت الفكرة 

تحياتي للجمع واعتذر عن الأطالة 

 

[محمد هشام.]

وعليكم السلام ورحمة الله تعالى وبركاته 

جرب هدا 

Option Explicit
Dim PassProtect As String, OnRng As Range
Private Const Clé As String = "1234"
Public Property Get WS() As Worksheet: Set WS = Sheets("Sheet1"): End Property

Sub Data_Protection()
    Dim linge As Variant
    Do
        linge = Application.InputBox("أدخل رقم الصف الأخير لقفل الخلايا", Type:=1)
        If linge = False Then Exit Sub
        If Not IsNumeric(linge) Or linge < 1 Or linge > WS.Rows.Count Then: MsgBox "خطأ في الإدخال"
       
            Exit Do
    Loop
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
' قم بتعديل النطاق بما يناسبك
Set OnRng = WS.Range("A2:M" & linge)
    With WS
        If .ProtectContents Then .Unprotect password:=Clé
        .Cells.Locked = False
        OnRng.FormulaHidden = True
        OnRng.Locked = True
        .Protect password:=Clé
    End With

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

    MsgBox linge & ":" & "تم قفل الحسابات بنجاح  لغاية الصف ", vbInformation
End Sub
'=======================================================================
Sub Data_UnProtection()
    Dim result As VbMsgBoxResult
   
    Do
        PassProtect = InputBox("أدخل كلمة المرور لفك الحماية")
        
        If PassProtect = "" Then Exit Sub

        If PassProtect = Clé Then
            Application.ScreenUpdating = False
            Application.Calculation = xlCalculationManual

            WS.Unprotect password:=Clé
            WS.Cells.Locked = False
            WS.Cells.FormulaHidden = False

            Application.ScreenUpdating = True
            Application.Calculation = xlCalculationAutomatic

            MsgBox "تم فتح جميع الحسابات بنجاح", vbInformation
            Exit Sub
        Else
            result = MsgBox( _
            "كلمة المرور غير صحيحة" & vbNewLine & "هل ترغب في المحاولة مرة أخرى؟", _
            vbCritical + vbYesNo, "خطأ في كلمة المرور")

            If result = vbNo Then
                MsgBox "تم إلغاء العملية", vbInformation
                Exit Sub
            End If
        End If
    Loop
End Sub

 

 

 

غلق المدى المحدد .xlsb

تم تعديل منذ 1 ساعه بواسطه محمد هشام.