Option Explicit
   
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
   
     If Not Intersect(Target, _
         Union(Range("B8:B10"), Range("D8:D10")) _
         ) Is Nothing Then
           
         Target.Value = Date
         Cancel = True
     End If
      
End Sub
   
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
     If Not Intersect(Target, _
         Union(Range("B8:B10"), Range("D8:D10")) _
         ) Is Nothing Then
       
         'ВКЛЮЧЕНИЕ ОБРАБОТЧИКОВ
           
         'день вперед/назад
         Application.OnKey "%{UP}", "DayAfter"      'Alt+СтрелкаВверх
         Application.OnKey "%{DOWN}", "DayBefore"   'Alt+СтрелкаВниз
          
         'месяц вперед/назад
         Application.OnKey "%{RIGHT}", "MonthAfter" 'Alt+СтрелкаВправо
         Application.OnKey "%{LEFT}", "MonthBefore" 'Alt+СтрелкаВлево
          
         'месяц вперед/назад по первым числам
         Application.OnKey "^%{UP}", "MonthAfterFirstDay"    'Ctrl+Alt+СтрелкаВверх
         Application.OnKey "^%{DOWN}", "MonthBeforeFirstDay" 'Ctrl+Alt+СтрелкаВниз
          
         'месяц вперед/назад по последним числам месяца
         Application.OnKey "^%{RIGHT}", "MonthAfterLastDay"  'Ctrl+Alt+СтрелкаВправо
         Application.OnKey "^%{LEFT}", "MonthBeforeLastDay"  'Ctrl+Alt+СтрелкаВлево
          
     Else
         'ВЫКЛЮЧЕНИЕ ОБРАБОТЧИКОВ -
         'возврат к нормальному поведению комбинаций
          
         Application.OnKey "%{UP}"
         Application.OnKey "%{DOWN}"
          
         Application.OnKey "%{RIGHT}"
         Application.OnKey "%{LEFT}"
          
         Application.OnKey "^%{UP}"
         Application.OnKey "^%{DOWN}"
          
         Application.OnKey "^%{RIGHT}"
         Application.OnKey "^%{LEFT}"
          
     End If
      
End Sub

Option Explicit
    
Public Sub DayAfter() 'день вперед
     On Error Resume Next
         ActiveCell.Value = ActiveCell.Value + 1
     On Error GoTo 0
End Sub
   
Public Sub DayBefore() 'день назад
     On Error Resume Next
         ActiveCell.Value = ActiveCell.Value - 1
     On Error GoTo 0
End Sub
   
Public Sub MonthAfter() 'месяц вперед
     On Error Resume Next
         ActiveCell.Value = DateAdd("m", 1, ActiveCell.Value)
     On Error GoTo 0
End Sub
   
Public Sub MonthBefore() 'месяц назад
     On Error Resume Next
         ActiveCell.Value = DateAdd("m", -1, ActiveCell.Value)
     On Error GoTo 0
End Sub
   
Public Sub MonthAfterFirstDay() 'месяц вперед по первым числам
     Dim m As Date
     On Error Resume Next
         m = DateAdd("m", 1, ActiveCell.Value)
         ActiveCell.Value = DateSerial(Year(m), Month(m), 1)
     On Error GoTo 0
End Sub
   
Public Sub MonthBeforeFirstDay() 'месяц назад по первым числам
     Dim m As Date
     Dim d As Date
     On Error Resume Next
         d = ActiveCell.Value
         If Day(d) > 1 Then
             ActiveCell.Value = DateSerial(Year(d), Month(d), 1)
         Else
             m = DateAdd("m", -1, ActiveCell.Value)
             ActiveCell.Value = DateSerial(Year(m), Month(m), 1)
         End If
     On Error GoTo 0
End Sub
   
Public Sub MonthAfterLastDay() 'месяц вперед по последним числам
     Dim m As Date
     Dim d As Date
     On Error Resume Next
         m = DateAdd("m", 1, ActiveCell.Value)
         d = ActiveCell.Value + 1
         If Month(d) <> Month(m) Then
             'еще в этом месяце
             ActiveCell.Value = DateSerial(Year(m), Month(m), 1) - 1
         Else
             'уже в следующем
             ActiveCell.Value = DateSerial(Year(m), Month(m) + 1, 1) - 1
         End If
     On Error GoTo 0
End Sub
   
Public Sub MonthBeforeLastDay() 'месяц назад по последним числам
     Dim d As Date
     On Error Resume Next
         d = ActiveCell.Value
         ActiveCell.Value = DateSerial(Year(d), Month(d), 1) - 1
     On Error GoTo 0
End Sub