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