Microsoft Excel - Optmizing macro

Hi,

I have the following macro that I wrote for a small excel project. As this excel has lots of records it is taking too much time to run the macro. Is there anything I can do to speed up the running time and optimize my code? I am new to vb, so any tips will be much appreciated.

Here is my code.

Public Const R7ExpiryDays As Integer = 3
Public Const DExpiryDays As Integer = 14
Public Const I123ExpiryDays As Integer = 30
Sub NoScreenRePainting()
Application.ScreenUpdating = False
DMOFeedback
Application.ScreenUpdating = True
End Sub
Sub DMOFeedback()

Dim LeadDt As Range
Dim AtDt1 As Range
Dim AtDt2 As Range
Dim AtDt3 As Range
Dim Rslt1 As String
Dim Rslt2 As String
Dim Rslt3 As String
Dim i As Double
Dim FinalRow As Double
Dim StartTime As Date
Dim EndTime As Date

ActiveCell.Select
ActiveSheet.Unprotect Password:="dmtm2009"

StartTime = Time

' Find the last row
Sheets("LeadTemplate").Select
FinalRow = Cells(Rows.Count, 3).End(xlUp).Row

For i = 13 To FinalRow
' Set the object
   Set LeadDt = Cells(i, 3)
   Set AtDt1 = Cells(i, 45)
'   Set Rslt1 = Cells(i, 46)
   Set AtDt2 = Cells(i, 47)
'   Set Rslt2 = Cells(i, 48)
   Set AtDt3 = Cells(i, 49)
'   Set Rslt3 = Cells(1, 50)
  
' move value from the cell to the variable
   LeadDt = Cells(i, 3).Value
   AtDt1 = Cells(i, 45).Value
   Rslt1 = Cells(i, 46).Value
   AtDt2 = Cells(i, 47).Value
   Rslt2 = Cells(i, 48).Value
   AtDt3 = Cells(i, 49).Value
   Rslt3 = Cells(i, 50).Value
  
  On Error GoTo Errorhandler
 
' call the subroutine to protect the cells
   If Not IsEmpty(LeadDt.Value) Then
      Worksheet_Change LeadDt, AtDt1, Rslt1, AtDt2, Rslt2, AtDt3, Rslt3, i
   End If
Next i
ActiveSheet.Protect Password:="dmtm2009", AllowFiltering:=True, AllowUsingPivotTables:=True, AllowFormattingCells:=True, AllowFormattingColumns:=True, AllowFormattingRows:=True

EndTime = Time

'MsgBox " StartTime is " & StartTime & " EndTime is " & EndTime

MsgBox "Save Complete. Thank you"

Exit Sub

Errorhandler:
ActiveSheet.Protect Password:="dmtm2009", AllowFiltering:=True, AllowUsingPivotTables:=True, AllowFormattingCells:=True, AllowFormattingColumns:=True, AllowFormattingRows:=True
MsgBox Err & ": " & Error(Err)

End Sub

Private Sub Worksheet_Change(ByVal LeadDate As Range, AtDate1 As Range, Result1 As String, AtDate2 As Range, Result2 As String, AtDate3 As Range, Result3 As String, x As Double)

' This is the code for Lead date

If LeadDate.Column = 3 Then
    If LeadDate.Value < Date Then
            LeadDate.Select
            Selection.Locked = True
            Cells(x, 1).Locked = True
            Cells(x, 2).Locked = True
    Else
            LeadDate.Select
            Selection.Locked = False
            Cells(x, 1).Locked = False
            Cells(x, 2).Locked = False
      End If
End If

' **************

' Code for Attempt Date 1

If AtDate1.Column = 45 Then
'    If Not IsEmpty(Result1.Value) Then
     If Result1 <> "" Then
       If IsEmpty(AtDate1.Value) Then
          AtDate1.Value = Date
       End If
       If AtDate1.Value < Date Then
          AtDate1.Select
          Selection.Locked = True
          Cells(x, 46).Locked = True
       Else
          AtDate1.Select
          Selection.Locked = False
          Cells(x, 46).Locked = False
       End If
' Set Expiry date if required
       Select Case Result1
            Case Is = "R7"
                 Select Case Weekday(AtDate1.Value)
                     Case Is = vbFriday
                        Cells(x, 55).Value = AtDate1.Value + R7ExpiryDays + 3
                     Case Is = vbSaturday
                        Cells(x, 55).Value = AtDate1.Value + R7ExpiryDays + 2
                     Case Is = vbSunday
                        Cells(x, 55).Value = AtDate1.Value + R7ExpiryDays + 1
                     Case Else
                        Cells(x, 55).Value = AtDate1.Value + R7ExpiryDays
                  End Select
            Case Is = "r7"
                 Select Case Weekday(AtDate1.Value)
                     Case Is = vbFriday
                        Cells(x, 55).Value = AtDate1.Value + R7ExpiryDays + 3
                     Case Is = vbSaturday
                        Cells(x, 55).Value = AtDate1.Value + R7ExpiryDays + 2
                     Case Is = vbSunday
                        Cells(x, 55).Value = AtDate1.Value + R7ExpiryDays + 1
                     Case Else
                        Cells(x, 55).Value = AtDate1.Value + R7ExpiryDays
                  End Select
            Case Is = "D1"
                    Select Case Weekday(AtDate1.Value)
                     Case Is = vbFriday
                        Cells(x, 55).Value = AtDate1.Value + DExpiryDays + 3
                     Case Is = vbSaturday
                        Cells(x, 55).Value = AtDate1.Value + DExpiryDays + 2
                     Case Is = vbSunday
                        Cells(x, 55).Value = AtDate1.Value + DExpiryDays + 1
                     Case Else
                        Cells(x, 55).Value = AtDate1.Value + DExpiryDays
                  End Select
                            
            Case Is = "D2"
                   Select Case Weekday(AtDate1.Value)
                     Case Is = vbFriday
                        Cells(x, 55).Value = AtDate1.Value + DExpiryDays + 3
                     Case Is = vbSaturday
                        Cells(x, 55).Value = AtDate1.Value + DExpiryDays + 2
                     Case Is = vbSunday
                        Cells(x, 55).Value = AtDate1.Value + DExpiryDays + 1
                     Case Else
                        Cells(x, 55).Value = AtDate1.Value + DExpiryDays
                  End Select
            Case Is = "d1"
                   Select Case Weekday(AtDate1.Value)
                     Case Is = vbFriday
                        Cells(x, 55).Value = AtDate1.Value + DExpiryDays + 3
                     Case Is = vbSaturday
                        Cells(x, 55).Value = AtDate1.Value + DExpiryDays + 2
                     Case Is = vbSunday
                        Cells(x, 55).Value = AtDate1.Value + DExpiryDays + 1
                     Case Else
                        Cells(x, 55).Value = AtDate1.Value + DExpiryDays
                  End Select
            Case Is = "d2"
                  Select Case Weekday(AtDate1.Value)
                     Case Is = vbFriday
                        Cells(x, 55).Value = AtDate1.Value + DExpiryDays + 3
                     Case Is = vbSaturday
                        Cells(x, 55).Value = AtDate1.Value + DExpiryDays + 2
                     Case Is = vbSunday
                        Cells(x, 55).Value = AtDate1.Value + DExpiryDays + 1
                     Case Else
                        Cells(x, 55).Value = AtDate1.Value + DExpiryDays
                  End Select
            Case Is = "I3"
                    Select Case Weekday(AtDate1.Value)
                     Case Is = vbFriday
                        Cells(x, 55).Value = AtDate1.Value + I123ExpiryDays + 3
                     Case Is = vbSaturday
                        Cells(x, 55).Value = AtDate1.Value + I123ExpiryDays + 2
                     Case Is = vbSunday
                        Cells(x, 55).Value = AtDate1.Value + I123ExpiryDays + 1
                     Case Else
                        Cells(x, 55).Value = AtDate1.Value + I123ExpiryDays
                  End Select
                
            Case Is = "I1"
                  Select Case Weekday(AtDate1.Value)
                     Case Is = vbFriday
                        Cells(x, 55).Value = AtDate1.Value + I123ExpiryDays + 3
                     Case Is = vbSaturday
                        Cells(x, 55).Value = AtDate1.Value + I123ExpiryDays + 2
                     Case Is = vbSunday
                        Cells(x, 55).Value = AtDate1.Value + I123ExpiryDays + 1
                     Case Else
                        Cells(x, 55).Value = AtDate1.Value + I123ExpiryDays
                  End Select
            Case Is = "I2"
                  Select Case Weekday(AtDate1.Value)
                     Case Is = vbFriday
                        Cells(x, 55).Value = AtDate1.Value + I123ExpiryDays + 3
                     Case Is = vbSaturday
                        Cells(x, 55).Value = AtDate1.Value + I123ExpiryDays + 2
                     Case Is = vbSunday
                        Cells(x, 55).Value = AtDate1.Value + I123ExpiryDays + 1
                     Case Else
                        Cells(x, 55).Value = AtDate1.Value + I123ExpiryDays
                  End Select
            Case Is = "i1"
                 Select Case Weekday(AtDate1.Value)
                     Case Is = vbFriday
                        Cells(x, 55).Value = AtDate1.Value + I123ExpiryDays + 3
                     Case Is = vbSaturday
                        Cells(x, 55).Value = AtDate1.Value + I123ExpiryDays + 2
                     Case Is = vbSunday
                        Cells(x, 55).Value = AtDate1.Value + I123ExpiryDays + 1
                     Case Else
                        Cells(x, 55).Value = AtDate1.Value + I123ExpiryDays
                  End Select
            Case Is = "i2"
                 Select Case Weekday(AtDate1.Value)
                     Case Is = vbFriday
                        Cells(x, 55).Value = AtDate1.Value + I123ExpiryDays + 3
                     Case Is = vbSaturday
                        Cells(x, 55).Value = AtDate1.Value + I123ExpiryDays + 2
                     Case Is = vbSunday
                        Cells(x, 55).Value = AtDate1.Value + I123ExpiryDays + 1
                     Case Else
                        Cells(x, 55).Value = AtDate1.Value + I123ExpiryDays
                  End Select
            Case Is = "i3"
                 Select Case Weekday(AtDate1.Value)
                     Case Is = vbFriday
                        Cells(x, 55).Value = AtDate1.Value + I123ExpiryDays + 3
                     Case Is = vbSaturday
                        Cells(x, 55).Value = AtDate1.Value + I123ExpiryDays + 2
                     Case Is = vbSunday
                        Cells(x, 55).Value = AtDate1.Value + I123ExpiryDays + 1
                     Case Else
                        Cells(x, 55).Value = AtDate1.Value + I123ExpiryDays
                  End Select
            Case Is = "R2"  'R2 is also a pending condition so should do nothing
                 Cells(x, 47).Locked = False
                 Cells(x, 48).Locked = False
                 Cells(x, 49).Locked = False
                 Cells(x, 50).Locked = False
            Case Is = "r2"
                 Cells(x, 47).Locked = False
                 Cells(x, 48).Locked = False
                 Cells(x, 49).Locked = False
                 Cells(x, 50).Locked = False
            Case Else       'For all other reject codes the user should not be able to enter further tries
                 Cells(x, 47).Locked = True
                 Cells(x, 48).Locked = True
                 Cells(x, 49).Locked = True
                 Cells(x, 50).Locked = True
       End Select
    End If
End If

' **************

' Code for Attempt Date 2
'If Not IsEmpty(Result1.Value) Then
If Result1 <> "" Then

If AtDate2.Column = 47 Then
'    If Not IsEmpty(Result2.Value) Then
     If Result2 <> "" Then
    
       If IsEmpty(AtDate2.Value) Then
          AtDate2.Value = Date
       End If
      
       If AtDate2.Value < Date Then
          AtDate2.Select
          Selection.Locked = True
          Cells(x, 48).Locked = True
       Else
          AtDate2.Select
          Selection.Locked = False
          Cells(x, 48).Locked = False
       End If

' Set Expiry date if required
       If Result1 = "R2" Or Result1 = "r2" Then
          Select Case Result2
           Case Is = "R7"
                 Select Case Weekday(AtDate2.Value)
                     Case Is = vbFriday
                        Cells(x, 55).Value = AtDate2.Value + R7ExpiryDays + 3
                     Case Is = vbSaturday
                        Cells(x, 55).Value = AtDate2.Value + R7ExpiryDays + 2
                     Case Is = vbSunday
                        Cells(x, 55).Value = AtDate2.Value + R7ExpiryDays + 1
                     Case Else
                        Cells(x, 55).Value = AtDate2.Value + R7ExpiryDays
                  End Select
            Case Is = "r7"
                 Select Case Weekday(AtDate2.Value)
                     Case Is = vbFriday
                        Cells(x, 55).Value = AtDate2.Value + R7ExpiryDays + 3
                     Case Is = vbSaturday
                        Cells(x, 55).Value = AtDate2.Value + R7ExpiryDays + 2
                     Case Is = vbSunday
                        Cells(x, 55).Value = AtDate2.Value + R7ExpiryDays + 1
                     Case Else
                        Cells(x, 55).Value = AtDate2.Value + R7ExpiryDays
                  End Select
            Case Is = "D1"
                    Select Case Weekday(AtDate2.Value)
                     Case Is = vbFriday
                        Cells(x, 55).Value = AtDate2.Value + DExpiryDays + 3
                     Case Is = vbSaturday
                        Cells(x, 55).Value = AtDate2.Value + DExpiryDays + 2
                     Case Is = vbSunday
                        Cells(x, 55).Value = AtDate2.Value + DExpiryDays + 1
                     Case Else
                        Cells(x, 55).Value = AtDate2.Value + DExpiryDays
                  End Select
                            
            Case Is = "D2"
                   Select Case Weekday(AtDate2.Value)
                     Case Is = vbFriday
                        Cells(x, 55).Value = AtDate2.Value + DExpiryDays + 3
                     Case Is = vbSaturday
                        Cells(x, 55).Value = AtDate2.Value + DExpiryDays + 2
                     Case Is = vbSunday
                        Cells(x, 55).Value = AtDate2.Value + DExpiryDays + 1
                     Case Else
                        Cells(x, 55).Value = AtDate2.Value + DExpiryDays
                  End Select
            Case Is = "d1"
                   Select Case Weekday(AtDate2.Value)
                     Case Is = vbFriday
                        Cells(x, 55).Value = AtDate2.Value + DExpiryDays + 3
                     Case Is = vbSaturday
                        Cells(x, 55).Value = AtDate2.Value + DExpiryDays + 2
                     Case Is = vbSunday
                        Cells(x, 55).Value = AtDate2.Value + DExpiryDays + 1
                     Case Else
                        Cells(x, 55).Value = AtDate2.Value + DExpiryDays
                  End Select
            Case Is = "d2"
                  Select Case Weekday(AtDate2.Value)
                     Case Is = vbFriday
                        Cells(x, 55).Value = AtDate2.Value + DExpiryDays + 3
                     Case Is = vbSaturday
                        Cells(x, 55).Value = AtDate2.Value + DExpiryDays + 2
                     Case Is = vbSunday
                        Cells(x, 55).Value = AtDate2.Value + DExpiryDays + 1
                     Case Else
                        Cells(x, 55).Value = AtDate2.Value + DExpiryDays
                  End Select
            Case Is = "I3"
                    Select Case Weekday(AtDate2.Value)
                     Case Is = vbFriday
                        Cells(x, 55).Value = AtDate2.Value + I123ExpiryDays + 3
                     Case Is = vbSaturday
                        Cells(x, 55).Value = AtDate2.Value + I123ExpiryDays + 2
                     Case Is = vbSunday
                        Cells(x, 55).Value = AtDate2.Value + I123ExpiryDays + 1
                     Case Else
                        Cells(x, 55).Value = AtDate2.Value + I123ExpiryDays
                  End Select
                
            Case Is = "I1"
                  Select Case Weekday(AtDate2.Value)
                     Case Is = vbFriday
                        Cells(x, 55).Value = AtDate2.Value + I123ExpiryDays + 3
                     Case Is = vbSaturday
                        Cells(x, 55).Value = AtDate2.Value + I123ExpiryDays + 2
                     Case Is = vbSunday
                        Cells(x, 55).Value = AtDate2.Value + I123ExpiryDays + 1
                     Case Else
                        Cells(x, 55).Value = AtDate2.Value + I123ExpiryDays
                  End Select
            Case Is = "I2"
                  Select Case Weekday(AtDate2.Value)
                     Case Is = vbFriday
                        Cells(x, 55).Value = AtDate2.Value + I123ExpiryDays + 3
                     Case Is = vbSaturday
                        Cells(x, 55).Value = AtDate2.Value + I123ExpiryDays + 2
                     Case Is = vbSunday
                        Cells(x, 55).Value = AtDate2.Value + I123ExpiryDays + 1
                     Case Else
                        Cells(x, 55).Value = AtDate2.Value + I123ExpiryDays
                  End Select
            Case Is = "i1"
                 Select Case Weekday(AtDate2.Value)
                     Case Is = vbFriday
                        Cells(x, 55).Value = AtDate2.Value + I123ExpiryDays + 3
                     Case Is = vbSaturday
                        Cells(x, 55).Value = AtDate2.Value + I123ExpiryDays + 2
                     Case Is = vbSunday
                        Cells(x, 55).Value = AtDate2.Value + I123ExpiryDays + 1
                     Case Else
                        Cells(x, 55).Value = AtDate2.Value + I123ExpiryDays
                  End Select
            Case Is = "i2"
                 Select Case Weekday(AtDate2.Value)
                     Case Is = vbFriday
                        Cells(x, 55).Value = AtDate2.Value + I123ExpiryDays + 3
                     Case Is = vbSaturday
                        Cells(x, 55).Value = AtDate2.Value + I123ExpiryDays + 2
                     Case Is = vbSunday
                        Cells(x, 55).Value = AtDate2.Value + I123ExpiryDays + 1
                     Case Else
                        Cells(x, 55).Value = AtDate2.Value + I123ExpiryDays
                  End Select
            Case Is = "i3"
                 Select Case Weekday(AtDate2.Value)
                     Case Is = vbFriday
                        Cells(x, 55).Value = AtDate2.Value + I123ExpiryDays + 3
                     Case Is = vbSaturday
                        Cells(x, 55).Value = AtDate2.Value + I123ExpiryDays + 2
                     Case Is = vbSunday
                        Cells(x, 55).Value = AtDate2.Value + I123ExpiryDays + 1
                     Case Else
                        Cells(x, 55).Value = AtDate2.Value + I123ExpiryDays
                  End Select
            Case Is = "R2"  'R2 is also a pending condition so should do nothing
                 Cells(x, 49).Locked = False
                 Cells(x, 50).Locked = False
            Case Is = "r2"
                 Cells(x, 49).Locked = False
                 Cells(x, 50).Locked = False
            Case Else       'For all other reject codes the user should not be able to enter further tries
                 Cells(x, 49).Locked = True
                 Cells(x, 50).Locked = True
        End Select
       End If
    End If
End If
End If

' **************

' Code for Attempt Date 3
'If Not IsEmpty(Result1.Value) Then
'If Not IsEmpty(Result2.Value) Then
If Result1 <> "" Then
If Result2 <> "" Then
If AtDate3.Column = 49 Then
'    If Not IsEmpty(Result3.Value) Then
     If Result3 <> "" Then
      
       If IsEmpty(AtDate3.Value) Then
          AtDate3.Value = Date
       End If
      
       If AtDate3.Value < Date Then
          AtDate3.Select
          Selection.Locked = True
          Cells(x, 50).Locked = True
       Else
          AtDate3.Select
          Selection.Locked = False
          Cells(x, 50).Locked = False
       End If
      
' Set Expiry date if required
       If Result1 = "R2" Or Result1 = "r2" Or Result2 = "R2" Or Result2 = "r2" Then
          Select Case Result3
           Case Is = "R7"
                 Select Case Weekday(AtDate3.Value)
                     Case Is = vbFriday
                        Cells(x, 55).Value = AtDate3.Value + R7ExpiryDays + 3
                     Case Is = vbSaturday
                        Cells(x, 55).Value = AtDate3.Value + R7ExpiryDays + 2
                     Case Is = vbSunday
                        Cells(x, 55).Value = AtDate3.Value + R7ExpiryDays + 1
                     Case Else
                        Cells(x, 55).Value = AtDate3.Value + R7ExpiryDays
                  End Select
            Case Is = "r7"
                 Select Case Weekday(AtDate3.Value)
                     Case Is = vbFriday
                        Cells(x, 55).Value = AtDate3.Value + R7ExpiryDays + 3
                     Case Is = vbSaturday
                        Cells(x, 55).Value = AtDate3.Value + R7ExpiryDays + 2
                     Case Is = vbSunday
                        Cells(x, 55).Value = AtDate3.Value + R7ExpiryDays + 1
                     Case Else
                        Cells(x, 55).Value = AtDate3.Value + R7ExpiryDays
                  End Select
            Case Is = "D1"
                    Select Case Weekday(AtDate3.Value)
                     Case Is = vbFriday
                        Cells(x, 55).Value = AtDate3.Value + DExpiryDays + 3
                     Case Is = vbSaturday
                        Cells(x, 55).Value = AtDate3.Value + DExpiryDays + 2
                     Case Is = vbSunday
                        Cells(x, 55).Value = AtDate3.Value + DExpiryDays + 1
                     Case Else
                        Cells(x, 55).Value = AtDate3.Value + DExpiryDays
                  End Select
                            
            Case Is = "D2"
                   Select Case Weekday(AtDate3.Value)
                     Case Is = vbFriday
                        Cells(x, 55).Value = AtDate3.Value + DExpiryDays + 3
                     Case Is = vbSaturday
                        Cells(x, 55).Value = AtDate3.Value + DExpiryDays + 2
                     Case Is = vbSunday
                        Cells(x, 55).Value = AtDate3.Value + DExpiryDays + 1
                     Case Else
                        Cells(x, 55).Value = AtDate3.Value + DExpiryDays
                  End Select
            Case Is = "d1"
                   Select Case Weekday(AtDate3.Value)
                     Case Is = vbFriday
                        Cells(x, 55).Value = AtDate3.Value + DExpiryDays + 3
                     Case Is = vbSaturday
                        Cells(x, 55).Value = AtDate3.Value + DExpiryDays + 2
                     Case Is = vbSunday
                        Cells(x, 55).Value = AtDate3.Value + DExpiryDays + 1
                     Case Else
                        Cells(x, 55).Value = AtDate3.Value + DExpiryDays
                  End Select
            Case Is = "d2"
                  Select Case Weekday(AtDate3.Value)
                     Case Is = vbFriday
                        Cells(x, 55).Value = AtDate3.Value + DExpiryDays + 3
                     Case Is = vbSaturday
                        Cells(x, 55).Value = AtDate3.Value + DExpiryDays + 2
                     Case Is = vbSunday
                        Cells(x, 55).Value = AtDate3.Value + DExpiryDays + 1
                     Case Else
                        Cells(x, 55).Value = AtDate3.Value + DExpiryDays
                  End Select
            Case Is = "I3"
                    Select Case Weekday(AtDate3.Value)
                     Case Is = vbFriday
                        Cells(x, 55).Value = AtDate3.Value + I123ExpiryDays + 3
                     Case Is = vbSaturday
                        Cells(x, 55).Value = AtDate3.Value + I123ExpiryDays + 2
                     Case Is = vbSunday
                        Cells(x, 55).Value = AtDate3.Value + I123ExpiryDays + 1
                     Case Else
                        Cells(x, 55).Value = AtDate3.Value + I123ExpiryDays
                  End Select
                
            Case Is = "I1"
                  Select Case Weekday(AtDate3.Value)
                     Case Is = vbFriday
                        Cells(x, 55).Value = AtDate3.Value + I123ExpiryDays + 3
                     Case Is = vbSaturday
                        Cells(x, 55).Value = AtDate3.Value + I123ExpiryDays + 2
                     Case Is = vbSunday
                        Cells(x, 55).Value = AtDate3.Value + I123ExpiryDays + 1
                     Case Else
                        Cells(x, 55).Value = AtDate3.Value + I123ExpiryDays
                  End Select
            Case Is = "I2"
                  Select Case Weekday(AtDate3.Value)
                     Case Is = vbFriday
                        Cells(x, 55).Value = AtDate3.Value + I123ExpiryDays + 3
                     Case Is = vbSaturday
                        Cells(x, 55).Value = AtDate3.Value + I123ExpiryDays + 2
                     Case Is = vbSunday
                        Cells(x, 55).Value = AtDate3.Value + I123ExpiryDays + 1
                     Case Else
                        Cells(x, 55).Value = AtDate3.Value + I123ExpiryDays
                  End Select
            Case Is = "i1"
                 Select Case Weekday(AtDate3.Value)
                     Case Is = vbFriday
                        Cells(x, 55).Value = AtDate3.Value + I123ExpiryDays + 3
                     Case Is = vbSaturday
                        Cells(x, 55).Value = AtDate3.Value + I123ExpiryDays + 2
                     Case Is = vbSunday
                        Cells(x, 55).Value = AtDate3.Value + I123ExpiryDays + 1
                     Case Else
                        Cells(x, 55).Value = AtDate3.Value + I123ExpiryDays
                  End Select
            Case Is = "i2"
                 Select Case Weekday(AtDate3.Value)
                     Case Is = vbFriday
                        Cells(x, 55).Value = AtDate3.Value + I123ExpiryDays + 3
                     Case Is = vbSaturday
                        Cells(x, 55).Value = AtDate3.Value + I123ExpiryDays + 2
                     Case Is = vbSunday
                        Cells(x, 55).Value = AtDate3.Value + I123ExpiryDays + 1
                     Case Else
                        Cells(x, 55).Value = AtDate3.Value + I123ExpiryDays
                  End Select
            Case Is = "i3"
                 Select Case Weekday(AtDate3.Value)
                     Case Is = vbFriday
                        Cells(x, 55).Value = AtDate3.Value + I123ExpiryDays + 3
                     Case Is = vbSaturday
                        Cells(x, 55).Value = AtDate3.Value + I123ExpiryDays + 2
                     Case Is = vbSunday
                        Cells(x, 55).Value = AtDate3.Value + I123ExpiryDays + 1
                     Case Else
                        Cells(x, 55).Value = AtDate3.Value + I123ExpiryDays
                  End Select
          End Select
       End If
    End If
End If
End If
End If

End Sub

It would be a lot easier to follow your code and the intentions behind it if you were to provide a sample workbook. I do however have a couple of comments after looking at your code for a while.

1) As general practice you really should start out any VBA code you write with an Option Explicit statement. That flags any syntax violations before you are trying to execute your code.

2) The DMOFeedback routine could be greatly simplified by eliminating all those unneccessary (and incorrect/missing) Set statements. It seems that you need to pass to your WorkSheet_Change (BTW it is probably not good practice to assign a name to a custom routine that is identical to that of a VBA event handler) routine only three variables:

- LeadDt
- AtDate1, and
- i

The remainder of the variables you are currently passing can be determined inside your Worksheet_Change routine by using the Range.Offset syntax, e.g. Set AtDate2 = AtDate1.Offset(0,1).

3) It is not clear to me why it is necessary to locking and unlock the cells. I am concerned that doing so unneccessarily consumes processor cycles.

4) I will not claim that my next suggestion will reduce the execution time of your code, but it certainly would improve legibility. By changing the variable to upper case in your Select Case statements you could eliminate about half of your code, e.g. Select Case UCase(Result1) would select both "R7" and "r7"

5) There is a lot of unneccessary repitition in your Worksheet_Change routine. Again I will not claim that following my suggestion will reduce your execution, but it certainly would make your code significantly more compact. You could introduce the function listed below and then use a single statement instead of the many you are currently using in your Select Case statements as shown in the code segment below.

Hope any of this helped,
Rolf

Private Sub Worksheet_Change(ByVal LeadDate As Range, AtDate1 As Range, x As Double)

...
          
   Select Case UCase(Result1)
      Case Is = "R7"
         Cells(x, 55) = ExpiryDate(AtDate1, R7ExpiryDays)
      Case Is = "D1", Is = "D2"
         Cells(x, 55) = ExpiryDate(AtDate1, DExpiryDays)
      Case Is = "I1", Is = "I2", Is = "I3"
         Cells(x, 55) = ExpiryDate(AtDate1, I123ExpiryDays)
  End Select

...
End Sub

Function ExpiryDate(atDate As Range, expDays As Integer) As Integer
    Select Case Weekday(atDate.Value)
        Case Is = vbFriday
           Cells(x, 55).Value = atDate.Value + expDays + 3
        Case Is = vbSaturday
           Cells(x, 55).Value = atDate.Value + expDays + 2
        Case Is = vbSunday
           Cells(x, 55).Value = atDate.Value + expDays + 1
        Case Else
           Cells(x, 55).Value = atDate.Value + expDays
     End Select
End Function