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

[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

تم تعديل نوفمبر 7, 2024 بواسطه محمد هشام.

[Mharee Accounting Albaig]

ششششششششششششششكرا جزيلا 

ربي يحفظكم 

[Mharee Accounting Albaig]

السلام عليم اخواني الأعزاء 

حقيقة جهد كبير وماقصرتوا , اليوم عندما جئت اطبق هذا الكود وجته يعمل بصورة جيدة ولكن المشكلة عندما اضع حدود اغلاق لو فرضنا لغاية الصف 15 يعمل طبيعي وعندما اطلب الفتح لابد من كلمة المرور الصحيحة واذا كانت كلمة المرور خطا لا يفتح وتخرج لي عبارة ( كلمة المرور خطا) 

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

 اتمنى ان اكون قد اوصلت الفكرة مع التقدير 

شكرا جزيلا لكافة اعضاء المنتدى 

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

[محمد هشام.]

في 6‏/1‏/2025 at 20:17, Mharee Accounting Albaig said:

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

 أظن أنه يمكننا إضافة شرط التحقق من كلمة المرور عند محاولة غلق الحسابات في الكود  بحيث لا يمكن لأي شخص تنفيذه إلا إذا كان يعرف كلمة المرور الصحيحة  هذا يضيف طبقة أمان إضافية للحماية ويضمن أن الشخص الذي يقوم بالعملية هو الشخص المخول فقط 

جرب هدا التعديل 

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

تم تعديل بالامس في 03:09 بواسطه محمد هشام.

[Mharee Accounting Albaig]

الششششششششششششششكر الجزيل 

ربي لا يحرمنا منكم