ehabaf2

كود الاستاذ الفاضل حسونه حسين و هو ينفذ المطلوب بشكل احترافى
Option Explicit Sub CClose()     Dim Ws As Worksheet, RangeArea As Range, C As Range, MergedRange As Range     kh_Application False     Set Ws = ThisWorkbook.ActiveSheet     With Ws     Set RangeArea = .Range(.Cells(1, 1).Address, .Cells(653, IIf(ActiveCell.Column = 1, 1, ActiveCell.Column - 1)).Address)     .Unprotect Password:="1"     If ActiveCell.Row <= 653 Then         For Each C In RangeArea             If C.MergeCells = True And C.MergeArea.Rows.Count = 1 Then                 Set MergedRange = C.MergeArea                 MergedRange.UnMerge                 MergedRange.HorizontalAlignment = xlCenterAcrossSelection             End If         Next C         RangeArea.Locked = True     End If     .Protect Password:="1", DrawingObjects:=True, Contents:=True, Scenarios:=True     End With     kh_Application True End Sub Sub COpen()     kh_Application False     ActiveSheet.Unprotect Password:="1"     If ActiveCell.Row <= 653 Then         Range(Cells(1, 1).Address, Cells(653, ActiveCell.Column).Address).Locked = False     End If     ActiveSheet.Protect Password:="1", DrawingObjects:=True, Contents:=True, Scenarios:=True     kh_Application True End Sub Sub kh_Application(ibol As Boolean)     With Application         .ScreenUpdating = ibol         .Calculation = IIf(ibol, -4105, -4135)         .EnableEvents = ibol     End With End Sub  
الف شكر استاذنا الفاضل حسونه حسين على تعبك و اهتمامك زادكم الله من فضله و علمه