Takes too long ‘calculating cells’
This code is taking way too long to display the actions that it executes. Excel takes too long "calculating cells." It didn’t used to be that way. I was wondering if anyone knows why this may be. The Excel file is large – over 8 MB. Is there a way to stop it from doing this? Thanks for your help! Code: -------------------- Private Sub Worksheet_Change(ByVal Target As Range) '----------------------------------------------------------------- Const WS_RANGE As String = "N:N" Dim Cmnt On Error GoTo ws_exit: Application.EnableEvents = False If Not Intersect(Target, Me.Range(WS_RANGE)) Is Nothing Then With Target If .Row 3 Then If Me.Cells(.Row, "N").Value = "" Or Me.Cells(.Row, "N").Value = "O" Or Me.Cells(.Row, "N").Value = "H" Then Me.Cells(.Row, "A").Resize(, 26).Interior.ColorIndex = 0 End If If Me.Cells(.Row, "N").Value = "C" And Me.Cells(.Row, "O").Value = "DR" Then Me.Cells(.Row, "A").Resize(, 26).Interior.ColorIndex = 39 End If If Me.Cells(.Row, "N").Value = "C" And Me.Cells(.Row, "O").Value = "HJB" Then Me.Cells(.Row, "A").Resize(, 26).Interior.ColorIndex = 6 End If If Me.Cells(.Row, "N").Value = "C" And Me.Cells(.Row, "O").Value = "DLH" Then Me.Cells(.Row, "A").Resize(, 26).Interior.ColorIndex = 7 End If If Me.Cells(.Row, "N").Value = "C" And Me.Cells(.Row, "O").Value = "FDC" Then Me.Cells(.Row, "A").Resize(, 26).Interior.ColorIndex = 4 End If If Me.Cells(.Row, "N").Value = "C" And Me.Cells(.Row, "O").Value = "CJ" Then Me.Cells(.Row, "A").Resize(, 26).Interior.ColorIndex = 45 End If If Me.Cells(.Row, "N").Value = "C" And Me.Cells(.Row, "O").Value = "RT" Then Me.Cells(.Row, "A").Resize(, 26).Interior.ColorIndex = 20 End If If Me.Cells(.Row, "N").Value = "C" And Me.Cells(.Row, "O").Value = "GRR" Then Me.Cells(.Row, "A").Resize(, 26).Interior.ColorIndex = 22 End If If Me.Cells(.Row, "N").Value = "C" And Me.Cells(.Row, "O").Value = "TRG" Then Me.Cells(.Row, "A").Resize(, 26).Interior.ColorIndex = 54 End If If Me.Cells(.Row, "N").Value = "C" And Me.Cells(.Row, "O").Value = "GP" Then Me.Cells(.Row, "A").Resize(, 26).Interior.ColorIndex = 50 End If If Me.Cells(.Row, "N").Value = "C" And Me.Cells(.Row, "O").Value = "DC" Then Me.Cells(.Row, "A").Resize(, 26).Interior.ColorIndex = 40 End If If Me.Cells(.Row, "N").Value = "" And Me.Cells(.Row, "O").Value = "JOINT" Then Set Cmnt = .Comment If Cmnt Is Nothing Then Me.Cells(.Row, "O").AddComment .Comment.Visible = True .Comment.Text Text:="COG MEs:" & Chr(10) .Comment.Shape.Select True Else .Comment.Visible = False End If End If If Me.Cells(.Row, "N").Value = "C" And Me.Cells(.Row, "O").Value = "JOINT" Then Me.Cells(.Row, "A").Resize(, 26).Interior.ColorIndex = 15 End If 'If Me.Cells(.Row, "O").Value = "JOINT" Then 'Set Cmnt = Me.Cells(.Row, "O").Comment ' If Cmnt Is Nothing Then ' ActiveCell(.Row, "O").AddComment ' ActiveCell(.Row, "O").Comment.Visible = True ' ActiveCell(.Row, "O").Comment.Text Text:="COG MEs:" & Chr(10) ' ActiveCell(.Row, "O").Comment.Shape.Select True ' Else ' Cmnt.Visible = False ' End If 'If Me.Cells(.Row, "N").Value = "C" And Me.Cells(.Row, "O").Value = "JOINT" Then 'Me.Cells(.Row, "A").Resize(, 26).Interior.ColorIndex = 15 'End If 'End If If Me.Cells(.Row, "N") = "C" Then Me.Cells(.Row, "Q").ClearContents End If If Me.Cells(.Row, "N").Value = "O" Then Me.Cells(.Row, "AS").Value = 1 Else Me.Cells(.Row, "AS").ClearContents End If If Me.Cells(.Row, "N").Value = "C" Then Me.Cells(.Row, "AT").Value = 1 Else Me.Cells(.Row, "AT").ClearContents End If If Me.Cells(.Row, "O").Value = "NO ACTION" Then Me.Cells(.Row, "N").ClearContents Me.Cells(.Row, "A").Resize(, 26).Interior.ColorIndex = 48 End If If Me.Cells(.Row, "N").Value = "H" And Me.Cells(.Row, "A").Value = "" Then Me.Cells(.Row, "A").Value = Date + 30 End If If Me.Cells(.Row, "N").Value = "O" And Me.Cells(.Row, "A").Value = "" Then Me.Cells(.Row, "A").Value = Me.Cells(.Row, "C") End If End If End With End If ws_exit: Application.EnableEvents = True If Target.Cells.Count 1 Or Target.HasFormula Then Exit Sub On Error Resume Next If Not Intersect(Target, Range("N:N")) Is Nothing Then Application.EnableEvents = False Target = UCase(Target) Application.EnableEvents = True End If On Error GoTo 0 If Target.Cells.Count 1 Or Target.HasFormula Then Exit Sub On Error Resume Next If Not Intersect(Target, Range("O:O")) Is Nothing Then Application.EnableEvents = False Target = UCase(Target) Application.EnableEvents = True End If On Error GoTo 0 End Sub -------------------- -- chris46521 ------------------------------------------------------------------------ chris46521's Profile: http://www.excelforum.com/member.php...o&userid=35909 View this thread: http://www.excelforum.com/showthread...hreadid=567528 |
All times are GMT +1. The time now is 06:43 PM. |
Powered by vBulletin® Copyright ©2000 - 2024, Jelsoft Enterprises Ltd.
ExcelBanter.com