Locking Merged cells before save

Option ExplicitPrivate Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Dim i As Long
    Dim j As Long
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    If ActiveSheet.Name = "Sheet1" Then 'change name of sheet as needed
         'Resume to next line if any error occurs
        On Error Resume Next
        Dim Cell As Range
        With ActiveSheet
             'First of all unprotect the entire sheet
            .Unprotect Password:=""
             'Now search for non blank cells and lock them and unlock blank cells
            For Each Cell In ActiveSheet.UsedRange
                i = Cell.Row
                j = Cell.Column
                If Cell.Value <> "" Then
                    If Cell.Locked = False Then
                        Cell.Locked = True
                    End If
                End If
            Next Cell
             'Protect with blank password, you can change it
            .Protect Password:=""
        End With
        Application.Calculation = xlCalculationAutomatic
        Application.DisplayAlerts = True
        Application.ScreenUpdating = True
    End If
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)Dim rng1 As Range
Dim rng2 As Range
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayAlerts = False
If ActiveSheet.Name = "Sheet1" Then 'change name of sheet as needed
     'Resume to next line if any error occurs
    On Error Resume Next
    Dim Cell As Range
    With ActiveSheet
         'First of all unprotect the entire sheet
        .unprotect Password:=""
         'Now search for non blank cells and lock them and unlock blank cells
        For Each Cell In ActiveSheet.UsedRange
           Set rng1 = Intersect(Cells.SpecialCells(xlFormulas), Cells.SpecialCells(xlBlanks))
           Set rng2 = Intersect(Cells.SpecialCells(xlConstants), Cells.SpecialCells(xlBlanks))
            ActiveSheet.UsedRange.Locked = False
    If Not rng1 Is Nothing Then rng1.Locked = True
    If Not rng2 Is Nothing Then rng2.Locked = True
                End If
            End If
        Next Cell
         'Protect with blank password, you can change it
        .Protect Password:=""
    End With
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End If
End Sub