VBA Macro Causing Excel to Freeze When 2nd Copy of Sheet Added to Workbook

[QMHsowden]

Hello,

I'm working with Office 365. I have 1 workbook called "Results" and another called "Templates", the sheet in question ("RMW") is copied via the "Move or Copy" method from book "Templates" to "Results".

In the sheet, there are three fields (H4,H5,H6) that need to be filled with specific text, or a message pops up, and the user is encouraged to close the workbook until updates can be made. This is done by the code included below. If these three fields are correctly filled in, a second copy of sheet "RMW" can be added to book "Results" with no problems. The problem arises if the first copy of "RMW" has blanks in the three fields.

If there are blanks and a second copy of the sheet is moved from "Templates" to "Results", the Excel interface becomes non-responsive. Excel doesn't crash, the workbooks can still be closed using the X in the corner, and that prompts the closing macro appropriately. The sheet also does copy over, if the workbook is saved and re-opened. However, the interface of both workbooks (and any other workbooks open) do not update or change at all. This problem does not occur if the sheet is duplicated within the "Results" workbook, only if moving one from "Templates" to "Results".

I am hoping someone could look at my code and see if they can identify what is causing this issue. This code is located in the corresponding sheet module.

Private Sub Worksheet_Change(ByVal Target As Range)
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual


    ''''''
    Dim OutApp As Object
    Dim OutMail As Object
    Dim mailText As String
    
    Dim cell As Range
    Dim acceptLots As Variant
    Dim newLot As VbMsgBoxResult
    
    acceptLots = Array("S210243043", "S190820029", "S161128029")
    
    If Not Intersect(Target, Me.Range("H4:H6")) Is Nothing Then
        Application.EnableEvents = False
    
        For Each cell In Target
            If cell.Value <> "" Then
    
            If Not IsNumeric(Application.Match(cell.Value, acceptLots, 0)) Then
                newLot = MsgBox("New lot detected. Reference values need to be changed." + vbNewLine + "Confirm new lot?", _
                vbOKCancel, "New Lot #?")
                
                    If newLot = vbOK Then
                    
                        cell.Value = ""
                    
                        MsgBox ("Request sent for update." + vbNewLine + "Please email Name with the new lot number and CoA." _
                        + vbNewLine + vbNewLine + "Results cannot be reported until the values have been updated." + vbNewLine + _
                        "Workbook will now attempt to close.")
                        
                        Set OutApp = CreateObject("Outlook.Application")
                        Set OutMail = OutApp.CreateItem(0)
                        
                            mailText = "New " + Cells(cell.Row, "F") + " detected in " + ActiveSheet.Name + "." + vbNewLine + _
                            "Please update macros and expected values rows. Thank you!"
                        
                            On Error Resume Next
                            With OutMail
                                .To = "email"
                                .Subject = "QC Template Update Request"
                                .Body = mailText
                                .Send
                            End With
                            On Error GoTo 0
                            
                        Set OutMail = Nothing
                        Set OutApp = Nothing
                        
                        ActiveWorkbook.Close
                    End If
                    
                    If newLot = vbCancel Then
                        cell.Value = ""
                    End If
                    
            End If
            
            End If
        Next
    End If
    
    '''''
    
errH:
    If Err.Number <> 0 Then MsgBox Err.Number & " " & Err.Description
    Application.EnableEvents = True
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

While I am aware that I could train users to avoid this problem by ensuring they fill in the three problem fields before adding a new sheet, I am both trying to understand what is causing this issue to avoid it in the future and to minimize the chances of users encountering frustrating errors.

Thank you for your time. Please let me know if there is further information needed.

[SamT]

From reading the code, I have to say that Blanks are allowed, even required.

The Event sub is ran whenever any one of the three cells is changed, and all three cells are checked each time it runs. Note that it will also run if more that one cell is changed at a time (For example: by another sub pasting in an array.) If user ignores those three cells, the Change Event won't run

The workbook is closed when 1)A cell has the wrong Lot #, and 2) A message requesting a new lot # is sent.

I suggest moving that entire section of code to it's own Procedure(s).

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    'Simple test
    If Target.Count > 1 Then Exit Sub

    If Not Intersect(Target, Me.Range("H4:H6")) Is Nothing Then ChecklLotNumber Target 'Target will be one cell
End Sub

Sub ChecklLotNumber(ByVal Target As Range)
'Incomplete Procedure. Example only
If Not IsNumeric(Application.Match(Target, acceptLots, 0)) Then
     newLot = MsgBox("New lot detected. Reference values need to be changed." + vbNewLine + "Confirm new lot?", _
     vbOKCancel, "New Lot #?")
                
     If newLot = vbOK Then
         cell.Value = ""

  'Call Message sender    
 End Sub

Sub MessageSender()
'Incomplete Procedure. Example only
mailText = "New " + Cells(cell.Row, "F") + " detected in " + ActiveSheet.Name + "." + vbNewLine + _
Please update macros and expected values rows. Thank you!"
End sub

Having several small Procedures that only do one thing makes troubleshooting easier

I don't know enough to suggest when to check for blank cells, but your code doesn't. The Deactivate Event is a possibility