I had this code working and after I put code in to automatically save the workbook on close I am getting this error.

This is the structure. I am autoprocessing emails I receive using a rule in outlook. The rule searches for new mail with a certain subject, moves it to a new folder, and runs a macro in outlook to copy the data from the email body to an excel file. The Excel file has an auto_open macro that appends the new data from each email to an access database, moves the data then to a new sheet, saves the workbook, and closes the file.

So when Outlook is processing the email it stops on this line:

Set xlSheet = xlWB.Sheets(1)


Full code:

Outlook

Option Explicit

Sub ProcessNewExpNote(olItem As Outlook.MailItem)

Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim vText As Variant
Dim sText As String
Dim vItem As Variant
Dim i As Long
Dim rCount As Long
Dim bXStarted As Boolean
Const strPath As String = "I:\My Documents\Projects\R2\Task 4 - GSDS Contractor DB\ProcessedReplies.xlsm"        'the path of the workbook


    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    If Err <> 0 Then
        Application.StatusBar = "Please wait while Excel source is opened ... "
        Set xlApp = CreateObject("Excel.Application")
        bXStarted = True
    End If
    On Error GoTo 0
    'Open the workbook to input the data
    Set xlWB = xlApp.Workbooks.Open(strPath)
    Set xlSheet = xlWB.Sheets(1)

    'Process the message record
    sText = olItem.Body
    vText = Split(sText, Chr(13))
    'Find the next empty line of the worksheet
    rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row
    rCount = rCount + 1

    'Check each line of text in the message body
    For i = UBound(vText) To 0 Step -1

        If InStr(1, vText(i), "Confirm Resource's Full Name:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("B" & rCount) = Trim(vItem(1))
        End If
        
        If InStr(1, vText(i), "Confirm Resource's SOEID:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("C" & rCount) = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "Extending (Yes/No):") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("D" & rCount) = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "New End Date (or confirm current - mm/dd/yyyy):") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("E" & rCount) = Trim(vItem(1))
        End If
        
        If InStr(1, vText(i), "GOC (if extending):") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("F" & rCount) = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "In Forecast (Yes/No):") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("G" & rCount) = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "Manager Approved (Yes/No):") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("H" & rCount) = Trim(vItem(1))
        End If
        
        xlSheet.Range("I" & rCount) = olItem.SenderName
        xlSheet.Range("J" & rCount) = Date
        
    Next i
    xlWB.Close
    If bXStarted Then
        xlApp.Quit
    End If
    Set xlApp = Nothing
    Set xlWB = Nothing
    Set xlSheet = Nothing


End Sub



Excel code in workbook:

Private Sub Workbook_Open()

If Worksheets("data").Range("C2").Value = "" Then
        Application.Wait (Now + TimeValue("0:00:03"))
End If
    
Call Export
    
End Sub

Excel Code in module:

Option Explicit

Sub Export()

Dim cn As ADODB.Connection, rs As ADODB.Recordset
Dim resSOEID, resExt, resNewDate, newGOC, forecastConf, manAppConf, confFrom, confReceived As String
Dim NextRow As String
Dim ws2 As Worksheet
    Set ws2 = ThisWorkbook.Sheets("archived")
Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("data")
Dim iRow As Integer
    iRow = 1

Application.DisplayAlerts = False

' connect to the Access database
Set cn = New ADODB.Connection
cn.Open "Provider=Microsoft.ACE.OLEDB.12.0; " & _
    "Data Source=I:\My Documents\Projects\R2\Task 4 - GSDS Contractor DB\DB.mdb;"
' open a recordset
Set rs = New ADODB.Recordset
rs.Open "Actions", cn, adOpenKeyset, adLockOptimistic, adCmdTable

Range("C2").Activate  ' row 1 contains column headings
Do While Not IsEmpty(ActiveCell)
    resSOEID = ActiveCell.Value
    resExt = ActiveCell.Offset(0, 1).Value
    resNewDate = ActiveCell.Offset(0, 2).Value
    newGOC = ActiveCell.Offset(0, 3).Value
    forecastConf = ActiveCell.Offset(0, 4).Value
    manAppConf = ActiveCell.Offset(0, 5).Value
    confFrom = ActiveCell.Offset(0, 6).Value
    confReceived = ActiveCell.Offset(0, 7).Value

    rs.Filter = "SOEID='" & resSOEID & "'"
    If rs.EOF Then
        Debug.Print "No existing record..."
    Else
        Debug.Print "Existing record found..."
    End If
    
        rs("Date of Confirmation").Value = confReceived
        rs("Manager Approval").Value = manAppConf
        rs("In Forecast").Value = forecastConf
        rs("Extending").Value = resExt
        rs("New Extension Date").Value = resNewDate
        rs("New GOC").Value = newGOC
        rs("Received From").Value = confFrom
    
        rs.Update
    
    Debug.Print "...record update complete."

    ActiveCell.Offset(1, 0).Activate  ' next cell down
Loop

rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing

ws2.Activate
Do While ws2.Cells(iRow, 3) <> ""
    iRow = iRow + 1
Loop

ws.Activate
ws.Range("B2:J2").Select
ws.Range("B2:J2").Copy

ws2.Activate
NextRow = ws2.Cells(iRow, 2).Address(RowAbsolute:=False, ColumnAbsolute:=False)
ws2.Range(NextRow & ":J" & iRow).PasteSpecial


ws.Activate
ws.Range("B2:J100").ClearContents
    If iRow > 1000 Then
        ws2.Activate
        ws2.Range("B2:J1001").ClearContents
    End If

ActiveWorkbook.Save
Application.DisplayAlerts = True
ActiveWorkbook.Close

End Sub