Need code to run faster

[User Name Active]

This code works great and does what I need it to, but it takes to long. I need users to run this code constantly and I need it to run faster.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim KeyCells As Range

 
    Set KeyCells = Range("D4:D8,D11")
    
    If Not Application.Intersect(KeyCells, Range(Target.Address)) _
           Is Nothing Then
  
Range("D14") = "=J41"
Range("D15") = "=K41"
Range("D16") = "=L41"
Range("D19") = "=M41"
Range("D20") = "=N41"
Range("D21") = "=O41"
Range("H14") = "=P41"
Range("H15") = "=Q41"
Range("H16") = "=R41"
Range("H17") = "=S41"
Range("H18") = "=T41"
Range("H19") = "=U41"
Range("H20") = "=V41"
Range("H21") = "=W41"
Range("H22") = "=X41"
Range("H23") = "=Y41"
Range("H24") = "=Z41"
Range("H25") = "=AA41"
Range("H26") = "=AB41"
Range("H27") = "=AC41"
Range("H28") = "=AD41"
Range("H29") = "=AE41"
Range("H30") = "=AF41"
Range("H31") = "=AG41"
Range("H32") = "=AH41"
Range("H33") = "=AI41"
Range("H34") = "=AJ41"


Set KeyCells = Range("D7:D7")
    
    If Not Application.Intersect(KeyCells, Range(Target.Address)) _
           Is Nothing Then

Range("D9") = "=C58"
Range("D10") = "=C59"
    End If
    
End If
    
End Sub

 

[Norie]

That code will call itself quite a few times.

Try turning off events to prevent that.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range

    Set KeyCells = Range("D4:D8,D11")

    If Not Application.Intersect(KeyCells, Target) Is Nothing Then
        Application.EnableEvents = False

        Range("D14") = "=J41"
        Range("D15") = "=K41"
        Range("D16") = "=L41"
        Range("D19") = "=M41"
        Range("D20") = "=N41"
        Range("D21") = "=O41"
        Range("H14") = "=P41"
        Range("H15") = "=Q41"
        Range("H16") = "=R41"
        Range("H17") = "=S41"
        Range("H18") = "=T41"
        Range("H19") = "=U41"
        Range("H20") = "=V41"
        Range("H21") = "=W41"
        Range("H22") = "=X41"
        Range("H23") = "=Y41"
        Range("H24") = "=Z41"
        Range("H25") = "=AA41"
        Range("H26") = "=AB41"
        Range("H27") = "=AC41"
        Range("H28") = "=AD41"
        Range("H29") = "=AE41"
        Range("H30") = "=AF41"
        Range("H31") = "=AG41"
        Range("H32") = "=AH41"
        Range("H33") = "=AI41"
        Range("H34") = "=AJ41"

        Set KeyCells = Range("D7")

        If Not Application.Intersect(KeyCells, Target) Is Nothing Then

            Range("D9") = "=C58"
            Range("D10") = "=C59"
        End If

    End If

    Application.EnableEvents = True

End Sub

 

[ParamRay]

Perhaps also clean it up.

Private Sub Worksheet_Change(ByVal Target As Range)

  Dim i As Integer
  
  Application.EnableEvents = False
  
  If Not Intersect(Me.Range("D4:D8,D11"), Target) Is Nothing Then
    For i = 10 To 36
      Select Case i
        Case Is < 13
          Me.Cells(i + 4, "D").Formula = "=" & Me.Cells(41, i).Address(False, False)
        Case Is < 16
          Me.Cells(i + 6, "D").Formula = "=" & Me.Cells(41, i).Address(False, False)
        Case Else
          Me.Cells(i - 2, "H").Formula = "=" & Me.Cells(41, i).Address(False, False)
      End Select
    Next i
  End If
  
  If Not Intersect(Me.Range("D7"), Target) Is Nothing Then
    Me.Range("D9:D10").Formula = "=C58"
  End If

  Application.EnableEvents = True
  
End Sub