Event Macro Not Calling Macro Or Crashing Excel

[matt767]

I want to call a macro when a cell in the range H2:FAX changes (for all sheets), where X is the last row. However I can't get the event macro posted in ThisWorkbook to call the macro consistently. I did get it to work a couple times by chance, and it worked fine for a while and then suddenly started crashing excel. Here is the code:

Private Sub Workbook_SheetChange2(ByVal Sh As Object, ByVal Target As Range)
Dim lr As Long
lr = Application.WorksheetFunction.CountA(Columns("A"))
Dim rng As Range
Set rng = Range("H2", Cells(lr, "FA"))
If Not Intersect(Target, rng) Is Nothing Then
Call check
End If
End Sub

Any help would be greatly appreciated.

 

[Domenic]

Try removing the number 2 from the name of the event handler. So try replacing...

Private Sub Workbook_SheetChange2(ByVal Sh As Object, ByVal Target As Range)

with

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

Hope this helps!

 

[matt767]

@Domenic It is now calling the macros - but for one of my macros which uses a function, it crashes excel. The other macro which doesn't use functions doesn't crash and works fine. Thanks, if you know why that one macro crashes excel when called by the event macro but not when I run it manually, please let me know.

 

[Domenic]

Can you post the code for your macro check ?

 

[matt767]

@Domenic here are the function and check macros. Thank you.

Function GetColorCount(CountRange As Range, CountColor As Range)
Dim CountColorValue As Integer
Dim TotalCount As Integer
CountColorValue = CountColor.Interior.ColorIndex
Set rCell = CountRange
For Each rCell In CountRange
  If rCell.Interior.ColorIndex = CountColorValue Then
    TotalCount = TotalCount + 1
  End If
Next rCell
GetColorCount = TotalCount
End Function

Sub check()
Dim lr As Long
lr = Application.WorksheetFunction.CountA(Columns("A"))
Range("LD1").FormulaR1C1 = "Total Complete"
Range("LE1").FormulaR1C1 = "Total Possible"
Range("LF1").FormulaR1C1 = "Percent Complete"
Range("LD1:LF1").EntireColumn.AutoFit
Dim tc As Long
Dim tp As Long
Dim rng As Range
Set rng = Range("H2", Cells(lr, "FA"))
Dim rng2 As Range
Dim cel As Range
For Each cel In rng
If GetColorCount(cel, Range("FF1")) = 1 Then
If rng2 Is Nothing Then
Set rng2 = cel
Else
Set rng2 = Union(rng2, cel)
End If
End If
Next cel
For Each cel In rng2
If InStr(Cells(1, cel.Column).Text, "unmapped") < 1 And Cells(1, cel.Column).Text <> "general" And Cells(1, cel.Column).Text <> "unknown" And cel.Value <> "" Then
tc = tc + 1
End If
Next cel
For Each cel In rng2
If InStr(Cells(1, cel.Column).Text, "additional image") < 1 And InStr(Cells(1, cel.Column).Text, "main image") < 1 And InStr(Cells(1, cel.Column).Text, "bullets") < 1 And Cells(1, cel.Column).Text <> "general" And Cells(1, cel.Column).Text <> "unknown" Then
tp = tp + 1
End If
Next cel
For Each cel In rng
If InStr(Cells(1, cel.Column).Text, "unmapped") > 0 Or Cells(1, cel.Column).Text = "general" Or Cells(1, cel.Column).Text = "unknown" Then
cel.Value = ""
End If
Next cel
Range("LD2").Value = tc
Range("LE2").Value = tp
Range("LF2").Formula = "=LD2/LE2"
Range("LF2").Select
Selection.Style = "Percent"
Dim lfv As Variant
lfv = Application.WorksheetFunction.IfError(Range("LF2").Value, "0")
If lfv = 1 And InStr(Application.WorksheetFunction.Concat(Range("H1:FA1")), "unmapped") < 1 Or Range("LE2").Value = 0 And InStr(Application.WorksheetFunction.Concat(Range("H1:FA1")), "unmapped") < 1 Then
    With ActiveWorkbook.ActiveSheet.Tab
        .Color = 5287936
        .TintAndShade = 0
    End With
Else
    With ActiveWorkbook.ActiveSheet.Tab
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
    End With
End If
Range("LD1:LF2").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 5287936
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
Range("H1").Select
End Sub

 

[bebo021999]

As I see in your code, you describe the actions as follows:

1. If there are any changes in the H2:FAx range (150 columns and x rows) of all the sheets due to user input, then call the "check" subroutine.
2. Within each sheet, you have a For loop directly iterating over each cell using "For Each cel In rng". If x=1000, then the number of cells to iterate through would be 150*1000 = 150,000 cells.
3. After that, you iterate over each cell in rng2 using "For Each cel In rng2".
4. Furthermore, you call "For Each cel In rng" once again and delete cells based on certain conditions
   
   I wouldn't be surprised if this process leads to Excel freezing or taking too long to process.
   Here's a suggestion for a possible solution:

Use an array variable to store the data and perform calculations on this array. Save the results in another array (result array). Once the calculations are complete, copy the result array back into the spreadsheet. Avoid working, doing calculation directly on sheet by all cost.

If you need specific assistance, please share your sample file through Google Drive, Dropbox, or any other file-sharing platform, and make sure to remove any sensitive data.

 

[matt767]

@bebo021999 I am sort of new to vba and will have to look into that. However, when I run the check macro manually (without using the event macro) it takes 2-3 seconds to calculate (on a sheet with 36 rows). I can whittle it down more by excluding extraneous columns that have no header (a sheet will have at most 20 or so columns with a header). It doesn't make sense that it works fine when run manually and not when called by the event macro. Thanks.

 

[bebo021999]

try to use array variable and working with it only, not directly on sheet.
For example:
Instead of rng as range:

Dim rng As Range
Set rng = Range("H2", Cells(lr, "FA"))

use rng as array:

Dim rng
rng = Range("H2", Cells(lr, "FA")).value

 

[Peter_SSs]

As well as the change suggested by @Domenic try adding these two red lines of code into your 'check' procedure where shown.

Sub check()
Dim lr As Long
Application.EnableEvents = False
lr = Application.WorksheetFunction.CountA(Columns("A"))

' rest of the code here

Range("H1").Select
Application.EnableEvents = True
End Sub

 

[matt767]

@Peter_SSs Thank you, that fixed the crash. @bebo021999 I will try your suggestion as well.