determine if workbook is already open

cmazur71

Board Regular
Joined
Aug 7, 2003
Messages
61
I need to determine if a workbook is already open. If it is already open, my code is generating an error.
I am copying a sheet from one workbook to another. If the source workbook is already open, it fails.
If the source workbook is already open, I want to display a message to the user "Workbook sourceworkbook is already open"

Here's what I have...it works great if sourceworkbook is not already open

RQTReport = Application.GetOpenFilename(, , "Browse for IPS / RQT Quotation") 'select a workbook to open
If RQTReport = "False" Then Exit Sub 'exit if user selects Cancel

Set currentworkbook = ThisWorkbook
Set sourceworkbook = Workbooks.Open(RQTReport)
sourceworkbook.Activate

For i = 1 To Worksheets.Count
If Worksheets(i).Name = "Export" Then 'from RQT 'check to see if any of the source workbook sheets are named Export
sourceworkbook.Sheets("Export").Copy before:=currentworkbook.Sheets("QuoteTemplate") 'THIS IS THE LINE THAT ERRORS IF THE WORKBOOK IS ALREADY OPEN
End If
Next i
 

Excel Facts

Save Often
If you start asking yourself if now is a good time to save your Excel workbook, the answer is Yes

Norie

Well-known Member
Joined
Apr 28, 2004
Messages
76,303
Office Version
  1. 365
Platform
  1. Windows
You could try using adding this function that tests, by name, if a workbook is open.
VBA Code:
Function IsWBOpen(strWBName As String) As Boolean
Dim wb As Workbook

    For Each wb In Application.Workbooks
        If wb.Name = strWBName Then
            IsWBOpen = True
            Exit Function
        End If
    Next wb

End Function
It could be used in your code like this.
VBA Code:
Dim strWBName As String

    RQTReport = Application.GetOpenFilename(, , "Browse for IPS / RQT Quotation")    'select a workbook to open
    If RQTReport = "False" Then Exit Sub    'exit if user selects Cancel
       
    strWBName = Dir(RQTReport)
    
    If IsWBOpen(strWBName) Then
        Set sourceworkbook = Workbooks(strWBName)
    Else
        Set sourceworkbook = Workbooks.Open(RQTReport)
    End If
    
    Set currentworkbook = ThisWorkbook
    
    For i = 1 To Worksheets.Count
        If Worksheets(i).Name = "Export" Then    'from RQT 'check to see if any of the source workbook sheets are named Export
            sourceworkbook.Sheets("Export").Copy before:=currentworkbook.Sheets("QuoteTemplate")    'THIS IS THE LINE THAT ERRORS IF THE WORKBOOK IS ALREADY OPEN
        End If
    Next i
 
Solution

Saurabhj

Active Member
Joined
Jun 6, 2020
Messages
457
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
Hi,

Another way:

VBA Code:
Dim RQTReport As String
Sub copy()
    RQTReport = Application.GetOpenFilename(, , "Browse for IPS / RQT Quotation") 'select a workbook to open
    If RQTReport = "False" Then Exit Sub 'exit if user selects Cancel
     Set currentworkbook = ThisWorkbook
    'Added below line
     If Not (AlreadyOpen(RQTReport)) Then Exit Sub

    Set sourceworkbook = Workbooks.Open(RQTReport)
    sourceworkbook.Activate
    
    For i = 1 To Worksheets.Count
    If Worksheets(i).Name = "Export" Then 'from RQT 'check to see if any of the source workbook sheets are named Export
    sourceworkbook.Sheets("Export").copy before:=currentworkbook.Sheets("QuoteTemplate") 'THIS IS THE LINE THAT ERRORS IF THE WORKBOOK IS ALREADY OPEN
    End If
    Next i
End Sub

'add below function
Function AlreadyOpen(sFname As String) As Boolean
    Dim wkb As Workbook
    On Error Resume Next
    Set wkb = Workbooks(sFname)
    AlreadyOpen = Not wkb Is Nothing
    Set wkb = Nothing
End Function
 

cmazur71

Board Regular
Joined
Aug 7, 2003
Messages
61
You could try using adding this function that tests, by name, if a workbook is open.
VBA Code:
Function IsWBOpen(strWBName As String) As Boolean
Dim wb As Workbook

    For Each wb In Application.Workbooks
        If wb.Name = strWBName Then
            IsWBOpen = True
            Exit Function
        End If
    Next wb

End Function
It could be used in your code like this.
VBA Code:
Dim strWBName As String

    RQTReport = Application.GetOpenFilename(, , "Browse for IPS / RQT Quotation")    'select a workbook to open
    If RQTReport = "False" Then Exit Sub    'exit if user selects Cancel
      
    strWBName = Dir(RQTReport)
   
    If IsWBOpen(strWBName) Then
        Set sourceworkbook = Workbooks(strWBName)
    Else
        Set sourceworkbook = Workbooks.Open(RQTReport)
    End If
   
    Set currentworkbook = ThisWorkbook
   
    For i = 1 To Worksheets.Count
        If Worksheets(i).Name = "Export" Then    'from RQT 'check to see if any of the source workbook sheets are named Export
            sourceworkbook.Sheets("Export").Copy before:=currentworkbook.Sheets("QuoteTemplate")    'THIS IS THE LINE THAT ERRORS IF THE WORKBOOK IS ALREADY OPEN
        End If
    Next i
Worked like a champ...thank you. I was prepared to display a message telling the user to close the open workbook...your solution was so much better. Thank you
 

Forum statistics

Threads
1,141,069
Messages
5,704,111
Members
421,327
Latest member
Msh

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top