VBA crashes randomly in middle of procedure for only one user

[logandiana]

I created a procedure that splits a file into a bunch of smaller workbooks and then emails them using outlook.
I rolled this out to approximately 20 users. It works fine on everyone's PC except one person. On her machine the macro seems to run fine and then excel crashes without warning like it was never opened in the first place. No error, no debug message, no warning... nothing. Then if you go to open the file again, you get the note on the left side asking if you want to open or keep a previous file when excel last closed unexpectedly.
I have stepped through it on her machine and it works fine. Only crashes when it is run from the beginning.
Any ideas? Possibly a memory/processing power issue?

Dim ARM, NBK, CList, user1 As Workbook
Dim DATA, UNI, NST, CList1, user2 As Worksheet
Dim Mlbox, ARDOC, OLNS, OLOE, fso, ts As Object
Dim i, j As Integer
Dim LR1, LR2, LR3, LR4, LR5 As Long
Dim who, FileName, MostRecentFile, FileSpec, SigString, Signature As String
Dim shp As Shape
Sub DoStuff()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set ARM = ThisWorkbook
Set DATA = ARM.Sheets("Data")
Set UNI = ARM.Sheets("UNIQUE")
UNI.Visible = True
who = Environ("USERNAME")
For Each shp In DATA.Shapes
shp.Delete
Next shp
FileSpec = "*.xlsx*"
Directory = ARM.Path & "\" & who & "\Exports\"
FileName = Dir(Directory & FileSpec)
If FileName <> "" Then
MostRecentFile = FileName
MostRecentDate = FileDateTime(Directory & FileName)
Do While FileName <> ""
If FileDateTime(Directory & FileName) > MostRecentDate Then
MostRecentFile = FileName
MostRecentDate = FileDateTime(Directory & FileName)
End If
FileName = Dir
Loop
End If
Workbooks.Open Directory & MostRecentFile
Set user1 = ActiveWorkbook
Set user2 = user1.Sheets(1)
user2.UsedRange.Copy DATA.Range("A1")
user1.Close
ARM.Activate
On Error Resume Next
Kill ARM.Path & "\" & who & "\SPLIT FILES\*.xlsx"
On Error GoTo 0
LR4 = DATA.Cells(Rows.Count, 1).End(xlUp).Row
Rows(LR4).Delete
DATA.Range("A1:A" & LR4 - 1).Copy UNI.Range("A1")
DATA.Range("B2:B" & LR4 - 1).Copy UNI.Range("A" & LR4)
Set CList = Workbooks.Open(ARM.Path & "\" & who & "\ContactList.xlsx")
Set CList1 = CList.Sheets(1)
ARM.Activate
UNI.Select
LR5 = UNI.Cells(Rows.Count, 1).End(xlUp).Row
UNI.Range("B" & LR4 & ":B" & LR5).FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-1],[ContactList.xlsx]Sheet1!C1:C11,4,0),"""")"
UNI.Range("B" & LR4 & ":B" & LR5).Value = UNI.Range("B" & LR4 & ":B" & LR5).Value
For i = LR5 To LR4 Step -1
If UNI.Cells(i, 2) <> "SHIP" Then
UNI.Range(Cells(i, 1), Cells(i, 2)).Delete
End If
Next i
UNI.Columns("B:B").ClearContents
UNI.Range("A:A").RemoveDuplicates 1, xlYes
CList1.Range("D1").Copy UNI.Range("C1")
LR2 = UNI.Cells(Rows.Count, 1).End(xlUp).Row
UNI.Range("B2:B" & LR2).FormulaR1C1 = "=IFERROR(IF(VLOOKUP(RC[-1],[ContactList.xlsx]Sheet1!C1:C11,2,0)=0,"""",VLOOKUP(RC[-1],[ContactList.xlsx]Sheet1!C1:C11,2,0)),""NoContact"")"
UNI.Range("C2:C" & LR2).FormulaR1C1 = "=IFERROR(IF(VLOOKUP(RC[-2],[ContactList.xlsx]Sheet1!C1:C11,3,0)=0,"""",VLOOKUP(RC[-2],[ContactList.xlsx]Sheet1!C1:C11,3,0)),""NoContact"")"
UNI.Range("H2:H" & LR2).FormulaR1C1 = "=IFERROR(IF(VLOOKUP(RC[-7],[ContactList.xlsx]Sheet1!C1:C11,4,0)=0,"""",VLOOKUP(RC[-7],[ContactList.xlsx]Sheet1!C1:C11,4,0)),"""")"
UNI.Range("B2:H" & LR2).Value = UNI.Range("B2:H" & LR2).Value
UNI.Range("B1") = "Account Name"
CList.Close
ARM.Activate
With DATA
.Select
.Rows("1:1").ClearFormats
LR1 = DATA.Cells(Rows.Count, 1).End(xlUp).Row
.Range("A1:J" & LR1).Select
.ListObjects.Add(xlSrcRange, .Range("A1:J" & LR1).CurrentRegion, , xlYes).Name = "Table1"
.ListObjects("Table1").TableStyle = "TableStyleMedium16"
.Range("A1") = "Bill To"
.Range("B1") = "Ship To"
.Range("C1") = "Document"
.Range("G1") = "Amount"
.Range("H1") = "PO"
.Range("I1") = "Order Confirmation"
.Range("J1") = "Days Past Due"
.Range("K1") = "      Comments      "
.Range("A2").Select
ActiveWindow.FreezePanes = True
.Columns("G:G").NumberFormat = "$#,##0.00_);[Red]($#,##0.00)"
.Range("G1").Font.ThemeColor = xlThemeColorDark1
.Range("A1:K1").HorizontalAlignment = xlCenter
.Range("A1:K1").EntireColumn.AutoFit
End With
LR2 = UNI.Cells(Rows.Count, 1).End(xlUp).Row
With UNI
.Range("D2:D" & LR2).FormulaR1C1 = "=IF(RC[4]=""SHIP"",IF(SUMIFS(Data!C[3],Data!C[-2],UNIQUE!RC[-3])<=0,""NoBalance"",SUMIFS(Data!C[3],Data!C[-2],UNIQUE!RC[-3])),IF(SUMIFS(Data!C[3],Data!C[-3],UNIQUE!RC[-3])<=0,""NoBalance"",SUMIFS(Data!C[3],Data!C[-3],UNIQUE!RC[-3])))"
.Range("E2:E" & LR2).FormulaR1C1 = "=IF(RC[3] = ""SHIP"",IF(SUMIFS(Data!C[2],Data!C[-3],UNIQUE!RC[-4],Data!C[5],"">0"")<=0,""NoPastDue"",SUMIFS(Data!C[2],Data!C[-3],UNIQUE!RC[-4],Data!C[5],"">0"")),IF(SUMIFS(Data!C[2],Data!C[-4],UNIQUE!RC[-4],Data!C[5],"">0"")<=0,""NoPastDue"",SUMIFS(Data!C[2],Data!C[-4],UNIQUE!RC[-4],Data!C[5],"">0"")))"
.Range("E2:D" & LR2).Value = .Range("E2:D" & LR2).Value
.Range("F2:F" & LR2).FormulaR1C1 = "=TEXT(RC[-2],""$ #,##0.00 ;"")"
.Range("G2:G" & LR2).FormulaR1C1 = "=TEXT(RC[-2],""$ #,##0.00 ;"")"
.Columns("F:G").NumberFormat = "@"
.Range("F2:G" & LR2).Value = .Range("F2:G" & LR2).Value
.Range("F1") = "TotalBalance"
.Range("G1") = "TotalPastDue"
.Columns("D:E").Delete
End With
For i = 2 To LR2
If UNI.Range("C" & i).Value = "NoContact" Then
    GoTo Nexti
End If
If UNI.Range("F" & i).Value = "SHIP" Then
DATA.UsedRange.AutoFilter 2, UNI.Range("A" & i).Value
Set NBK = Workbooks.Add
Set NST = NBK.Sheets(1)
DATA.UsedRange.SpecialCells(xlCellTypeVisible).Copy NST.Range("A1")
NST.Range("L1") = "Data current as of: " & Date + Time
NST.Columns("A:L").EntireColumn.AutoFit
NBK.SaveAs ARM.Path & "\" & who & "\SPLIT FILES\" & UNI.Range("A" & i).Value & ".xlsx"
NBK.Close True
DATA.UsedRange.AutoFilter
Else
DATA.UsedRange.AutoFilter 1, UNI.Range("A" & i).Value
Set NBK = Workbooks.Add
Set NST = NBK.Sheets(1)
DATA.UsedRange.SpecialCells(xlCellTypeVisible).Copy NST.Range("A1")
NST.Range("L1") = "Data current as of: " & Date + Time
NST.Columns("A:L").EntireColumn.AutoFit
NBK.SaveAs ARM.Path & "\" & who & "\SPLIT FILES\" & UNI.Range("A" & i).Value & ".xlsx"
NBK.Close True
DATA.UsedRange.AutoFilter
End If
Nexti:
Next i
DATA.Range("A1:K1").AutoFilter
ActiveWindow.FreezePanes = False
LR3 = UNI.Cells(Rows.Count, 1).End(xlUp).Row
SigString = Environ("appdata") & "\Microsoft\Signatures\" & who & ".htm"
Signature = GetSigFile(SigString)
Set Mlbox = CreateObject("Outlook.Application")
For j = 2 To LR3
If UNI.Cells(j, 3).Value = "NoContact" Then
    GoTo Nextj
End If
If UNI.Cells(j, 4).Value = "NoBalance" Then
Set ARDOC = Mlbox.CreateItem(0)
On Error GoTo SomethingIsWrong
With ARDOC
.BodyFormat = olFormatHTML
.To = UNI.Cells(j, 3).Value
.Subject = "Current Statement " & UNI.Cells(j, 1).Value & " " & UNI.Cells(j, 2).Value
.HTMLBody = "To whom it may concern,

I hope this email finds you well.  Attached is an updated statement for account " & UNI.Cells(j, 1).Value & " as of " & Date & ".

Please let me know if there are any questions or concerns regarding the statement.

" _
& Signature & "[COLOR=#003399]ALC[/COLOR]"
.Attachments.Add (ARM.Path & "\" & who & "\SPLIT FILES\" & UNI.Cells(j, 1).Value & ".xlsx")
.Importance = 2
.Save
End With
ElseIf UNI.Cells(j, 5).Value = "NoPastDue" Then
Set ARDOC = Mlbox.CreateItem(0)
On Error GoTo SomethingIsWrong
With ARDOC
.BodyFormat = olFormatHTML
.To = UNI.Cells(j, 3).Value
.Subject = "Current Statement " & UNI.Cells(j, 1).Value & " " & UNI.Cells(j, 2).Value
.HTMLBody = "To whom it may concern,

I hope this email finds you well.  Attached is an updated statement for account " & UNI.Cells(j, 1).Value & " as of " & Date & ".
Your total balance is [B]" & UNI.Cells(j, 4).Value & "[/B]

Please let me know if there are any questions or concerns regarding the statement.

" _
& Signature & "[COLOR=#003399]ALC[/COLOR]"
.Attachments.Add (ARM.Path & "\" & who & "\SPLIT FILES\" & UNI.Cells(j, 1).Value & ".xlsx")
.Importance = 2
.Save
End With
Else
Set ARDOC = Mlbox.CreateItem(0)
On Error GoTo SomethingIsWrong
With ARDOC
.BodyFormat = olFormatHTML
.To = UNI.Cells(j, 3).Value
.Subject = "Current Statement " & UNI.Cells(j, 1).Value & " " & UNI.Cells(j, 2).Value
.HTMLBody = "To whom it may concern,

I hope this email finds you well.  Attached is an updated statement for account " & UNI.Cells(j, 1).Value & " as of " & Date & ".
Your total balance is [B]" & UNI.Cells(j, 4).Value & "[/B]of which [B]" & UNI.Cells(j, 5).Value & "[/B] is past due.
Please provide the payment status for the past due invoices at your earliest convenience.

Please let me know if there are any questions or concerns regarding the statement.

" _
& Signature & "[COLOR=#003399]ALC[/COLOR]"
.Attachments.Add (ARM.Path & "\" & who & "\SPLIT FILES\" & UNI.Cells(j, 1).Value & ".xlsx")
.Importance = 2
.Save
End With
End If
Nextj:
Next j
UNI.UsedRange.AutoFilter 3, "NoContact"
LR5 = UNI.Cells(Rows.Count, 1).End(xlUp).Row
If LR5 = 1 Then
UNI.UsedRange.AutoFilter
GoTo NoneMissing
End If
Set NBK = Workbooks.Add
Set NST = NBK.Sheets(1)
UNI.UsedRange.SpecialCells(xlCellTypeVisible).Copy NST.Range("A1")
NST.UsedRange.EntireColumn.AutoFit
NST.Cells(1, 3).ClearContents
NST.Columns("B:B").Delete
NBK.SaveAs ARM.Path & "\" & who & "\SPLIT FILES\" & "AccountsMissingFromContactList.xlsx"
NBK.Close True
UNI.UsedRange.AutoFilter
Set ARDOC = Mlbox.CreateItem(0)
With ARDOC
.To = UNI.Cells(1, 3).Value
.Subject = "Missing Contacts"
.Body = "Attached is a list of accounts that need a contact in your ContactList file."
.Attachments.Add (ARM.Path & "\" & who & "\SPLIT FILES\" & "AccountsMissingFromContactList.xlsx")
.Save
End With
NoneMissing:
UNI.UsedRange.EntireColumn.AutoFit
UNI.Cells(1, 3).ClearContents
DATA.Range("M1") = Date + Time
DATA.Columns("M").EntireColumn.AutoFit
ARM.SaveAs FileName:=ARM.Path & "\" & who & "\COMPLETED\" & who & "_AR.STATEMENTS " & Format(Now(), "M-DD-YY hh.mm AMPM") & ".xlsx", FileFormat:=xlOpenXMLWorkbook
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "WELL DONE!"
Exit Sub
SomethingIsWrong:
ARM.Saved = True
MsgBox "Something went wrong, Excel will now close"
Application.Quit
End Sub
Function GetSigFile(ByVal SigString As String) As String
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(SigString).OpenAsTextStream(1, -2)
GetSigFile = ts.readall
ts.Close
End Function

 

[JLGWhiz]

You could check the ThisWorkbook code module to see if there is any event code being triggered that might create a conflict in the compiler or a memory problems that could shut the application down. Hard to tell without seeing the actual workstation and its attributes. But if you stepped through the procedure, that should have shown up there.