Intermittent Run-time Error 1004 or 13 in Excel 365 - excel

Question

I am at a loss, I have been working to create this macro to help automate an obnoxious process we have at work and the best way to sum up where it is right now is, 60% of the time it works every time!
The macro takes a workbook with the raw data, reorders the columns, filters out data based on certain criteria, creates separate files for each unique value in one of the columns and then attaches that newly created workbook to an email. The email has text and a logo that is placed into the body of the email. Altogether, when the macro finishes running, it will create anywhere from 7 to 11 separate files and emails.
The problem I am having is when I run the macro, 1 of the following 3 things happens:
No issue, it runs perfectly as expected
I get Run-time error '1004':
Method 'SaveAs' of object '_Workbook' failed
This error happens on this line in the code:
ActiveWorkbook.SaveAs FName
I get Run-time error '13':
Type mismatch
This error happens on this line in the code:
OutMailDocument.Range(0, 1).InsertBefore EmailText
I have tried searching several sites and although I can find information about the errors, I can't seem to find anything that has provided any help in fixing the problem.
I do not know where in my macro I went wrong, but I don't understand why sometimes it works just fine and other times I get one of the 2 errors?
Anyway, I am hoping someone may be able to help provide some guidance as to where I am going wrong. I have posted the full code below for reference:
Sub FeeManagement()
Dim CurrentColumn As Integer
Dim Columnheading As String
Dim lastrow As Long
Dim columnorder As Variant, ndx As Integer
Dim found As Range, counter As Integer
Dim wb As Workbook, ws As Worksheet
Dim lr As Long
Dim i As Integer
Dim ar As Variant
Dim j As Long
Dim rng As Range
Dim OutApp As Object
Dim Outmail As Object
Dim OutMailDocumet As Object
Dim OutShape As Excel.Shape
Dim OutWorksheet As Excel.Worksheet
Dim FName As String
Dim FPath As String
Application.ScreenUpdating = False
ActiveSheet.Cells.Interior.Color = xlNone
Range("A1").End(xlDown).Offset(1).Resize(ActiveSheet.UsedRange.Rows.Count).EntireRow.Delete
ActiveSheet.Cells.Font.Name = "Arial"
ActiveSheet.Cells.Font.Size = "10"
Sheets("Sheet1").Copy before:=Sheets(Sheets.Count)
ActiveSheet.Name = "Original"
Worksheets("Sheet1").Activate
'Remove Unwanted Columns
For CurrentColumn = ActiveSheet.UsedRange.Columns.Count To 1 Step -1
Columnheading = ActiveSheet.UsedRange.Cells(1, CurrentColumn).Value
Select Case Columnheading
Case "Auditor", "Auditor ID", "SAI. Nbr", "Pol. Form", "Pol. Nbr", "Aud. Type", "Days todue date", "Pol. Eff Date", "End Date", "Due Date", "Ins. Name", _
"State", "Market Group", "Scheduled Dt.", "Assigned Date", "CI Date", "Aud. System Key"
Case Else
ActiveSheet.Columns(CurrentColumn).Delete
End Select
Next
'Rearrange Columns
columnorder = Array("Auditor", "Assigned Date", "SAI. Nbr", "Ins Name", "State", "Pol. Eff Date", "End Date", "Due Date", "Pol. Form", "Pol. Nbr", "Days to ue date", _
"MarketGroup", "Aud. Type", "Aud. System Key", "Scheduled DT.", "CI Date", "Auditor ID")
counter = 1
For ndx = LBound(columnorder) To UBound(columnorder)
Set found = Rows("1:1").Find(columnorder(ndx), LookIn:=xlValues, Lookat:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
If Not found Is Nothing Then
If found.Column <> counter Then
found.EntireColumn.Cut
Columns(counter).Insert Shift:=xlToRight
Application.CutCopyMode = False
End If
counter = counter + 1
End If
Next ndx
'Add Due Date Columns and Amend Auditor Column
Range("K1").Value = "Days To Due Date"
Columns("L:L").Insert Shift:=xlToRight, _
CopyOrigin:=xlFormatFromLeftOrAbove
Range("L1").Value = "Days Assigned"
Range("S1").Value = "Sched DT Helper"
Range("T1").Value = "CI Helper"
With Sheets("Sheet1")
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
With .Range("K2:K" & lastrow)
.NumberFormat = "0"
End With
With .Range("L2:L" & lastrow)
.Formula = "=-(B2-Today())"
.NumberFormat = "0"
End With
With .Range("S2:S" & lastrow)
.Formula = "=(Q2-Today())"
.NumberFormat = "0"
End With
With .Range("T2:T" & lastrow)
.Formula = "=ABS(Q2-Today())"
.NumberFormat = "0"
End With
End With
Columns("A:B").Insert Shift:=xlToRight, _
CopyOrigin:=xlFormatFromLeftOrAbove
Range("B1").Value = "Auditor"
With Sheets("Sheet1")
lastrow = .Cells(.Rows.Count, "C").End(xlUp).Row
With .Range("B2:B" & lastrow)
.Formula = "=left(C,25)"
End With
End With
Sheets("Sheet1").Columns("B").Copy
Sheets("Sheet1").Columns("A").PasteSpecial Paste:=xlPasteValues
Columns("B:C").EntireColumn.Delete
Worksheets("Sheet1").Columns("A:Z").AutoFit
Worksheets("Sheet1").Range("A1").AutoFilter
'Filter and Delete records based on assigned/due dates & scheduled DT/CI Dates
Set ws = ActiveSheet
On Error Resume Next
ws.ShowAllData
On Error GoTo 0
ws.Range("A1:A20000").AutoFilter Field:=12, Criteria:="<=6"
Application.DisplayAlerts = False
ws.Range("A2:Z20000").SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
ws.ShowAllData
ws.Range("A1:A20000").AutoFilter Field:=11, Criteria:=">=30"
Application.DisplayAlerts = False
ws.Range("A2:Z20000").SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
ws.ShowAllData
ws.Range("A1:A20000").AutoFilter Field:=19, Criteria:=">=-3"
Application.DisplayAlerts = False
ws.Range("A2:Z20000").SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
ws.ShowAllData
ws.Range("A1:A20000").AutoFilter Field:=20, Criteria:="<=6"
Application.DisplayAlerts = False
ws.Range("A2:Z20000").SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
ws.ShowAllData
On Error Resume Next
ws.ShowAllData
On Error GoTo 0
Columns("S:T").EntireColumn.Delete
Columns("P:Q").EntireColumn.Delete
ws.AutoFilter.Sort.SortFields.Clear
ws.AutoFilter.Sort.SortFields.Add2 Key:=Range( _
"K1:K10000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ws.AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Columns("P:T").Insert Shift:=xlToRight, _
CopyOrigin:=xlFormatFromLeftOrAbove
Range("P1").Value = "New Status"
Range("Q1").Value = "New Status Text"
Range("R1").Value = "Date"
Range("S1").Value = "New Status Date"
Range("T1").Value = "Host Status"
'Create separate worksheets
Set wb = ActiveWorkbook
Set ws = ActiveSheet
lr = ws.Range("A" & Rows.Count).End(xlUp).Row
Set rng = ws.Range("A1:A" & lr)
j = ws.[A1].CurrentRegion.Columns.Count + 1
rng.AdvancedFilter 2, , ws.Cells(1, j), True
ar = ws.Range(ws.Cells(2, j), ws.Cells(Rows.Count, j).End(xlUp))
ws.Columns(j).Clear
For i = 1 To unbound(ar)
rng.AutoFilter 1, ar(i, 1)
If Not Evaluate("=ISREF('" & ar(i, 1) & "'!A10") Then
Sheets.Add(after:=Sheets(Sheets.Count)).Name = ar(i, 1)
Else
Sheets(ar(i, 1)).Move after:=Sheets(Sheets.Count)
End If
ws.Range("A1:A" & lr).Resize(, j - 1).Copy [A1]
Next
ws.AutoFilterMode = False
Sheet("Sheet1").Name = "Modified"
'Create separate files and email
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> "original" And ws.Name <> "Modified" Then
ws.Copy
Workbooks("Fee Management Macro.xlsm").Sheets("List").Copy before:=Sheets(Sheets.Count)
Range("A2:A13").Select
ActiveWorkbook.Names.Add Name:="StatusList", RefersToR1C1:="=List!R2C1:R12C1"
ActiveWorkbook.Names("StatusList").Comment = ""
Worksheets("Lis").Visible = False
Rows("2:2").Select
ActiveWindow.FreezePanes = True
With ActiveSheet
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
With .Range("S2:S" & lastrow)
.Formula = "=Now()"
End With
With .Range("T2:T") & lastrow
.Formula = "=IFERROR(VLOOKUP(RC[-4],List!C[-19]:[C-18],2,FALSE,"""")"
End With
With .Range("P2:P" & lastrow).Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=Statuslist"
.IgnoreBlank = False
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = "Select Status"
.ErrorMessage = "Please select status from the list"
.ShowInput = True
.ShowError = True
End With
With .Range("Q2:Q" & lastrow).Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=0", Formula2:="460"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = "Max 460 Characters"
.InputMessage = "If black, do not complete"
.ErrorMessage = "Max 460 Characters"
.ShowInput = True
.ShowError = True
End With
With .Range("R2:R" & lastrow).Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlGreater, Formula1:="11/1/2012"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = "Invalid Date"
.InputMessage = "If black, do not complete"
.ErrorMessage = "Please enter a valid date."
.ShowInput = True
.ShowError = True
End With
With .Range("P2:P" & lastrow).Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent4
.TintAndShade = 0.599993896298105
.Patterntintshade = 0
End With
With .Range("Q2:Q" & lastrow).Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.Patterntintshade = 0
End With
With .Range("R2:R" & lastrow).Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.Patterntintshade = 0
End With
With .Range("R2:R" & lastrow).FormatConditions
.Add Type:=xlExpression, Formula1:= _
"=$P2=""Contacted Insured"""
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent4
.TinAndShade = 0.599963377788629
End With
Selection.FormatConditions(1).StopIfTrue = False
End With
With .Range("R2:R" & lastrow).FormatConditions
.Add Type:=xlExpression, Formula1:= _
"=$P2=""Appointment Date Set"""
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent4
.TinAndShade = 0.599963377788629
End With
Selection.FormatConditions(1).StopIfTrue = False
End With
With .Range("R2:R" & lastrow).FormatConditions
.Add Type:=xlExpression, Formula1:= _
"=$P2=""Close Out Submitted"""
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent4
.TinAndShade = 0.599963377788629
End With
Selection.FormatConditions(1).StopIfTrue = False
End With
With .Range("R2:R" & lastrow).FormatConditions
.Add Type:=xlExpression, Formula1:= _
"=$P2=""Contacted Agent"""
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent4
.TinAndShade = 0.599963377788629
End With
Selection.FormatConditions(1).StopIfTrue = False
End With
With .Range("R2:R" & lastrow).FormatConditions
.Add Type:=xlExpression, Formula1:= _
"=$P2=""Other"""
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent4
.TinAndShade = 0.599963377788629
End With
Selection.FormatConditions(1).StopIfTrue = False
End With
End With
Rows("1:1").Select
With Selection
.Font.Bold = True
.Font.Underline = xlUnderlineStyleSingle
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
ActiveSheet.Columns("A:Z").AutoFit
ActiveSheet.Columns("A:Z").HorizontalAlignment = xlCenter
ActiveSheet.Columns("A:Z").VerticalAlignment = xlCenter
ActiveSheet.Range("A1").AutoFilter
With ActiveSheet.Sort
.SortFields.Add Key:=Range("K1"), Order:=xlAscending
.Header = xlYes
.Apply
End With
lcol = Cells(1, Columns.Count).End(xlToLeft).Column
lrow = Cells(Rows.Count, "A").End(xlUp).Row
Range(Cells(1, lcol + 1), Cells(Rows.Count, Columns.Count)).EntireColumn.Hidden = True
Range(Cells(lrow + 1, 1), Cells(Rows.Count, Columns.Count)).EntireRow.Hidden = True
Columns("C").Hidden = True
Columns("O").Hidden = True
Columns("S").Hidden = True
Columns("T").Hidden = True
Columns("U").Hidden = True
Range("A1").Select
Selection.AutoFilter
Range("R:R").Select
Selection.NumberFormat = "yyy-mm-dd;#"
Range("H;H,G:G,F;F,B:B").Select
Selection.NumberFormat = "m/d/yyy"
Range("D:D,A:A").Select
Range("A1").Activate
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Rows("1:1").Select
With Selection
.HorizontalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Columns("A:A").ColumnWidth = 25
Columns("D:D").ColumnWidth = 30
Columns("P:P").ColumnWidth = 30
Columns("Q:Q").ColumnWidth = 35
Columns("R:R").ColumnWidth = 10
Range("P:P,Q:Q,R:R").Locked = False
ActiveSheet.Protect Password:="ChrisBrianGreg2020", Userinterfaceonly:=True
FName = ws.Name & ".xlsx"
ActiveWorkbook.SaveAs FName
Set EmailText = Workbooks("Fee Management Macro.xlsm").Sheets("List").Range("M14")
Set OutWorksheet = Workbooks("Fee Management Macro.xlsm").Sheets("List")
Set OutApp = CreateObject("Outlook.Application")
Set Outmail = OutApp.CreateItem(OutAppOutMailItem)
Set OutMailDocument = Outmail.GetInspector.WordEditor
On Error Resume Next
With Outmail
.To = ""
.CC = ""
.BCC = ""
.Subject = "Weekly Inventory Status Update -" & " " & Date & " " & "-" & " " & ws.Name
.Body = ""
.Attachments.Add ActiveWorkbook.FullName
.Display
End With
On Error GoTo 0
'Copy Images to the email
For Each OutShape In OutWorksheet.Shapes
OutShape.Copy
OutMailDocument.Range(0, 1).Paste
Next
OutMailDocument.Range(0, 1).InsertBefore EmailText
Application.CutCopyMode = False
FName = Application.ActiveWorkbook.FullName
ActiveWorkbook.Saved = True
Application.ActiveWorkbook.ChangeFileAccess xlReadOnly
Kill FName
Application.ActiveWorkbook.Close False
End If
Next ws
Set Outmail = Nothing
Set OutApp = Nothing
Application.ScreenUpdating = True
End Subenter code here