'Шифрование текущего листа
Sub Encrypt()
    Dim Pass$, Key$
    Pass = InputBox("Введите ключ для шифрования:")
    Key = WorksheetFunction.Rept(Pass, 100)
     
    With Application
        KeepCalc = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
   For Each cell In Union(ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants), ActiveSheet.UsedRange.SpecialCells(xlCellTypeFormulas))
            Out = ""
            Txt = cell.Formula
            For i = 1 To Len(Txt)
                Out = Out & Chr((Asc(Mid(Txt, i, 1)) + Asc(Mid(Key, i, 1))) Mod 256)
            Next i
            cell.Value = Out
        Next cell
        .Calculation = KeepCalc
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub
  
'Дешифрация текущего листа
Sub Decrypt()
    Dim Pass$, Key$
    Pass = InputBox("Введите ключ для расшифровки:")
    Key = WorksheetFunction.Rept(Pass, 100)
     
    With Application
        KeepCalc = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
        For Each cell In ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants)
            Out = ""
            Txt = cell.Value
            For i = 1 To Len(Txt)
                Out = Out & Chr((Asc(Mid(Txt, i, 1)) - Asc(Mid(Key, i, 1)) + 256) Mod 256)
            Next i
            cell.Formula = Out
        Next cell
        .Calculation = KeepCalc
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

Sub Encrypt()
    Dim Pass$, Key$
    Dim ar
    Dim i&, j&, k&
    '    Pass = InputBox("Введите ключ для шифрования:")
    Pass = "ЗИМА"
    Key = WorksheetFunction.Rept(Pass, 100)
    With ActiveSheet.UsedRange
        ar = .Formula
        For i = LBound(ar) To UBound(ar)
            For j = LBound(ar, 2) To UBound(ar, 2)
                If Len(ar(i, j)) > Len(Key) Then
                    Key = WorksheetFunction.Rept(Pass, Len(ar(i, j)) \ Len(Pass) + 1)
                End If
                For k = 1 To Len(ar(i, j))
                    Mid$(ar(i, j), k, 1) = Chr((Asc(Mid(ar(i, j), k, 1)) + Asc(Mid(Key, k, 1))) Mod 256)
                Next
            Next
        Next
        .Cells(1).Resize(UBound(ar), UBound(ar, 2)).Value = ar
    End With
End Sub
Sub Decrypt()
    Dim Pass$, Key$
    Dim ar
    Dim i&, j&, k&
    '    Pass = InputBox("Введите ключ для расшифровки:")
    Pass = "ЗИМА"
    Key = WorksheetFunction.Rept(Pass, 100)
    With ActiveSheet.UsedRange
        ar = .Formula
        For i = LBound(ar) To UBound(ar)
            For j = LBound(ar, 2) To UBound(ar, 2)
                If Len(ar(i, j)) > Len(Key) Then
                    Key = WorksheetFunction.Rept(Pass, Len(ar(i, j)) \ Len(Pass) + 1)
                End If
                For k = 1 To Len(ar(i, j))
                    Mid$(ar(i, j), k, 1) = Chr((Asc(Mid(ar(i, j), k, 1)) - Asc(Mid(Key, k, 1)) + 256) Mod 256)
                Next k
            Next
        Next
        .Cells(1).Resize(UBound(ar), UBound(ar, 2)).Formula = ar
    End With
End Sub