VBA Error when multiple workbooks open

[kelseyvdh]

Hi everyone, I found this almost perfect working code, except for one thing: when I've another workbook open, it gives an error at this line:

Set oXLws = oXLwb.Sheets("Overview")

Would it be possible to make this work without errors when I've already opened several other workbooks?
Here's the full code:

Const xlUp As Long = -4162
Sub ExportToExcel(MyMail As MailItem)
    Dim strID As String, olNS As Outlook.NameSpace
    Dim olMail As Outlook.MailItem
    Dim strFileName As String
    '~~> Excel Variables
    Dim oXLApp As Object, oXLwb As Object, oXLws As Object
    Dim lRow As Long
    strID = MyMail.EntryID
    Set olNS = Application.GetNamespace("MAPI")
    Set olMail = olNS.GetItemFromID(strID)
    '~~> Establish an EXCEL application object
    On Error Resume Next
    Set oXLApp = GetObject(, "Excel.Application")
    '~~> If not found then create new instance
    If Err.Number <> 0 Then
        Set oXLApp = CreateObject("Excel.Application")
    End If
    Err.Clear
    On Error GoTo 0
    '~~> Show Excel
    oXLApp.Visible = True
    '~~> Open the relevant file
    Set oXLwb = oXLApp.Workbooks.Open("C:\  HERE'S THE LOCATION")
    oXLwb.Activate
    On Error Resume Next
    Set oXLws = oXLwb.Sheets("Overview")
    
    '~~> Set the relevant output sheet. Change as applicable
    On Error Resume Next
    
    lRow = oXLwb.Sheets("Overview").Range("E" & oXLApp.Rows.Count).End(xlUp).Row + 1
    '~~> Write to outlook
    With oXLwb.Sheets("Overview")
        '
        '~~> Code here to output data from email to Excel File
        '~~> For example
        '
        .Range("D" & lRow).Value = (Now)
        .Range("E" & lRow).Value = olMail.Subject
        .Range("G" & lRow).Value = olMail.Body
        '
    End With
    '~~> Close and Clean up Excel
    'oXLwb.Close (True)
    'oXLApp.Quit
    Set oXLws = Nothing
    Set oXLwb = Nothing
    Set oXLApp = Nothing
    Set olMail = Nothing
    Set olNS = Nothing
End Sub

Thanks!

[gmayor]

The macro needs a little bit more in the way of error handling (and there is no need to activate the sheet or the workbook when you have defined them with variable names) but otherwise it works. However the bigger problem is that of storing the message body in a cell. That can create all kinds of compatibility issues and is best avoided.

Option Explicit

Const xlUp As Long = -4162
Sub ExportToExcel(MyMail As MailItem)
Dim strID As String, olNS As Outlook.NameSpace
Dim olMail As Outlook.MailItem
Dim strFileName As String
    '~~> Excel Variables
Dim oXLApp As Object, oXLwb As Object, oXLws As Object
Dim lRow As Long
    strID = MyMail.EntryID
    Set olNS = Application.GetNamespace("MAPI")
    Set olMail = olNS.GetItemFromID(strID)
    '~~> Establish an EXCEL application object
    On Error Resume Next
    Set oXLApp = GetObject(, "Excel.Application")
    '~~> If not found then create new instance
    If Err.Number <> 0 Then
        Set oXLApp = CreateObject("Excel.Application")
    End If
    Err.Clear
    '~~> Show Excel
    oXLApp.Visible = True
    '~~> Open the relevant file

    Set oXLwb = oXLApp.Workbooks("C:\Path\Forums\OutlookLog.xlsx")
    If oXLwb Is Nothing Then
        Set oXLwb = oXLApp.Workbooks.Open("C:\Path\Forums\OutlookLog.xlsx")
    End If

    For Each oXLws In oXLwb.Sheets
        If oXLws.Name = "Overview" Then
            Exit For
        End If
    Next oXLws
    If oXLws Is Nothing Then
        MsgBox "Worksheet not found"
        GoTo lbl_Exit
    End If
    
    On Error GoTo 0


    lRow = oXLws.Range("E" & oXLApp.Rows.Count).End(xlUp).Row + 1
    '~~> Write to outlook
    With oXLws
        '
        '~~> Code here to output data from email to Excel File
        '~~> For example
        '
        .Range("D" & lRow).Value = (Now)
        .Range("E" & lRow).Value = olMail.Subject
        .Range("G" & lRow).Value = olMail.Body
        '
    End With
    '~~> Close and Clean up Excel
    'oXLwb.Close (True)
    'oXLApp.Quit
lbl_Exit:
    Set oXLws = Nothing
    Set oXLwb = Nothing
    Set oXLApp = Nothing
    Set olMail = Nothing
    Set olNS = Nothing
    Exit Sub
End Sub