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

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:

  1. No issue, it runs perfectly as expected

  2. I get Run-time error '1004': Method 'SaveAs' of object '_Workbook' failed

This error happens on this line in the code: ActiveWorkbook.SaveAs FName

  1. 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
excelvbaruntime-error


Sources

This article follows the attribution requirements of Stack Overflow and is licensed under CC BY-SA 3.0.

Source: Stack Overflow

Solution Source

Related Questions

Reading Excel file with Selenium WebDriver C# and web form with values

How to update an existing row or table of an existing xlsx file using pyexcel for python

Equivalent C# Function For Excels Norm.S.Inv Function

I keep assigning a value to my variable but it stays empty

Excel RTD (Real Time Data) client other than Excel?

Create table from data on a worksheet with specific name and add column

Is it possible to use 'Microsoft.ACE.OLEDB.12.0' provider without installation?

Using VBA to query a SQL Server table in Excel

How to stop scroll bar auto jump in vba

If IsEmpty then go to column A but in same row and extract that data

How can I use a for each loop on an array?

VBA - worksheet object is hidden

Outlook 2010 GAL with Excel VBA

how to read a value from Column Name in Excel in Java

Replace cell value with image