VBA keeps trying to open Worksheet, but don't want it to

Question

I've got a VBA that writes e-mails from outlook to excel. However, I want this excel sheet to remain open. Currently i've got the sheet to stay open (and just save after an e-mail goes into it), but each time i receive a new e-mail into my work book, it asks me to reopen the workbook as the VBA is telling it to open the workbook.

Here is the code:

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, fRow 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:\Rachael\VBAs\Control Panels.xlsm")

    '~~> Set the relevant output sheet. Change as applicable
    Set oXLws = oXLwb.Sheets("Ash Data")

    '~~> Write to outlook
    With oXLws
        '~~> Code here to output data from email to Excel File
        '~~> For example

        '* insert into last row (old alternative)
        '* you can remove this and the declare of lRow (at the top) if you don't need the old last row insert anymore.
        'lRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1 'next new row
        '.Range("A" & lRow).Value = olMail.Body 'write into last row

        '* insert into first row
        fRow = 1 'first row
        .Rows(fRow).Insert Shift:=xlDown
        .Range("A" & fRow).Value = olMail.Body 'write into first row
    End With

    '~~> Close and Clean up Excel
    oXLwb.Save
    Set oXLws = Nothing
    Set oXLwb = Nothing
    Set oXLApp = Nothing

    Set olMail = Nothing
    Set olNS = Nothing

End Sub

I'm not sure where I am going wrong with this code, but perhaps someone knows a solution to this?

Answer 1

As mentioned by @Shai in the comments, the issue is that your macro is opening the Workbook every time it is run regardless of whether the Workbook is already open. Siddharth Rout's answer to this question provides a IsWorkBookOpen function which will check whether the workbook is open or not, you can then open the workbook if it returns False:

Function IsWorkBookOpen(FileName As String)

Dim ff As Long, ErrNo As Long

On Error Resume Next
ff = FreeFile()
Open FileName For Input Lock Read As #ff
Close ff
ErrNo = Err
On Error GoTo 0

Select Case ErrNo
    Case 0:    IsWorkBookOpen = False
    Case 70:   IsWorkBookOpen = True
    Case Else: Error ErrNo
End Select

End Function

Then you can change your code to the following:

'~~> Open the relevant file
If IsWorkBookOpen("\\C:\Rachael\VBAs\Control Panels.xlsm") Then
    Set oXLwb = oXLApp.Workbooks("Control Panels.xlsm")
Else
    Set oXLwb = oXLApp.Workbooks.Open("\\C:\Rachael\VBAs\Control Panels.xlsm")
End If

Answer 2

Or, you can use another method to check if your Workbook is already open, without error traps. You can loop through the open Excel workbooks, and compare them to the FullName you are looking for ("\\C:\Rachael\VBAs\Control Panels.xlsm").

If there is a match >> then Set oXLwb to that workbook.

If there isn't a match >> then Open the relevant workbook.

Code

Dim oXLApp As Object, oXLwb As Object, oXLws As Object
Dim XLopenWB As Object
Dim Flag As Boolean

Flag = False
For Each XLopenWB In oXLApp.Workbooks
    If XLopenWB.FullName Like "\\C:\Rachael\VBAs\Control Panels.xlsm" Then
        Flag = True
        Set oXLwb = XLopenWB
        Exit For
    End If
Next XLopenWB

If Not Flag Then
    ' open the relevant workbook
    Set oXLwb = oXLApp.Workbooks.Open("\\C:\Rachael\VBAs\Control Panels.xlsm")
End If