VBA code stopping when secondary workbook manually closed (waiting for user to close second workbook) - excel

I'm looking to have primary workbook (WorkbookA), open a second workbook (WorkbookB) and test for a value within it. Value to match is in WorkbookA, cell B3 and is the number 1. Range to test in WorkbookB is "A:A".
If the value is not found, WorkbookB is reopened for the user to edit (will optimize to reduce opening/closing, any ideas on getting user input to resume would be appreciated after editing Workbook B), and the code in WorkbookA loops and retests if WorkbookB is still open every 10 seconds.
After the user edits WorkbookB to ensure the value is present, they close it (any better way to signal they are complete is welcomed so I don';t have to close and reopen the files. They are small, so it's not an issue for speed, just seems inefficient).
The assumption I had was that the code would then detect the workbook was closed and then continue code execution, but the VBA is stopping as soon as I select the X in the top right corner of Workbook B.
Would prefer not having separate code in personal.xls file because of multiple users.
Thanks,
Aaron
Code in Workbook A:
Global Const strWBb As String = "C:\Users\ashepherd\Desktop\WorkbookB.xlsx"
Global Const strRng As String = "A:A"
Sub Validate()
' ***************************** CHECK WORKBOOKB FOR 1 IN COLUMN A:A *****************************
' Verify presence on item in second workbook
searchItem = ThisWorkbook.Worksheets("Sheet1").Range("B3").Value
Do While Verify(searchItem, False) = False
Call Verify("", True)
Do While IsWorkBookOpen(strWBb) = True
endTime = DateAdd("s", 10, Now())
Do While Now() < endTime
DoEvents
Loop
Loop
Debug.Print "Workbook closed"
Loop
Debug.Print "search item found"
End Sub
Function Verify(item, OpenOnly As Boolean) As Boolean
' ****************************************************************************
' Open workbook B and verify that presence of item
' ****************************************************************************
Dim wbVerify As Workbook
Dim rng1 As Range
' ************************** OPEN FILE ************************************************
If IsFile(strWBb) Then
Set wbVerify = Application.Workbooks.Open(FileName:=strWBb, UpdateLinks:=False, IgnoreReadOnlyRecommended:=True) ' Open WorkbookB
wbVerify.Worksheets("Sheet1").Select
Else
MsgBox " File path incorrect. Unable to open.", vbCritical
Exit Function
End If
' ************************** TEST FOR ITEM ************************************************
If OpenOnly = True Then ' Only opening the file for read/write. Not testing values.
MsgBox "Opening workbook so values can be added. Close when additions completed."
Else
MsgBox ("Workbook B opened. Testing value for " & item & " in column A:A in Workbook B")
Set rng1 = Range(strRng).Find(item, , xlValues, xlWhole)
If Not rng1 Is Nothing Then
MsgBox item & " found !"
Verify = True
wbVerify.Close
GoTo item_found
Else
MsgBox (item & " not found in column A:A. Closing Workbook B. *****User will be promoted at this point to exit, or re-open the file to modify the values so search value is found in column A:A. Code SHOULD resume when Workbook B is closed. Currently VBA code execution in Workbook A is stopping when the 'X' is selected in top right window of Workbook B*****")
Verify = False
wbVerify.Close
End If
End If
Normal_exit:
Exit Function
item_found:
MsgBox "Verify code complete"
GoTo Normal_exit
End Function
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
Function IsFile(ByVal fName As String) As Boolean
'Returns TRUE if the provided name points to an existing file.
'Returns FALSE if not existing, or if it's a folder
On Error Resume Next
IsFile = ((GetAttr(fName) And vbDirectory) <> vbDirectory)
End Function
Final code:
Global Const strWBb As String = "C:\Users\ashepherd\Desktop\WorkbookB.xlsx"
Global Const strRng As String = "A:A"
Global Complete As Boolean
Sub Validate()
' ***************************** CHECK WORKBOOK_B FOR 1 IN COLUMN A:A *****************************
' Verify presence on item in second workbook
searchItem = ThisWorkbook.Worksheets("Sheet1").Range("B3").Value
Do While Verify(searchItem) = False
Complete = False
UserForm1.Show vbModeless ' USerform has a single button which changes the global "Complete" variable to true
Do While Complete = False
DoEvents
Loop
UserForm1.Hide
Debug.Print "Manual Edit Complete, retesting"
Loop
End Sub
Function Verify(item) As Boolean
' Modified to close only upon finding search item vs. reopening it.
' ****************************************************************************
' Open workbook B and verify that presence of item
' ****************************************************************************
Dim wbVerify As Workbook
Dim rng1 As Range
' ************************** OPEN FILE ************************************************
If IsFile(strWBb) Then
Set wbVerify = GetWorkbook(strWBb)
If Not wbVerify Is Nothing Then
Debug.Print wbVerify.Name
End If
wbVerify.Worksheets("Sheet1").Select
Else
MsgBox " File path incorrect. Unable to open.", vbCritical
Exit Function
End If
' ************************** TEST FOR ITEM ************************************************
Set rng1 = Range(strRng).Find(item, , xlValues, xlWhole)
If Not rng1 Is Nothing Then
Verify = True
GoTo item_found
Else
MsgBox (item & " not found in column A:A. A pop up form will show. Edit document and then hit RESUME button to continue checking. DO NOT exit via the close icon in the top right window of Excel as the code will stop running.")
Verify = False
End If
Normal_exit:
Exit Function
item_found:
'MsgBox (item & " found in WorkbookB, column A:A. Verify code complete")
wbVerify.Close Savechanges:=True
GoTo Normal_exit
End Function
Function IsFile(ByVal fName As String) As Boolean
'Returns TRUE if the provided name points to an existing file.
'Returns FALSE if not existing, or if it's a folder
On Error Resume Next
IsFile = ((GetAttr(fName) And vbDirectory) <> vbDirectory)
End Function
Public Function GetWorkbook(ByVal sFullName As String) As Workbook
' https://stackoverflow.com/questions/9373082/detect-whether-excel-workbook-is-already-open, modified to add ignorereadonly and update links
Dim sFile As String
Dim wbReturn As Workbook
sFile = Dir(sFullName)
On Error Resume Next
Set wbReturn = Workbooks(sFile)
If wbReturn Is Nothing Then
Set wbReturn = Application.Workbooks.Open(FileName:=sFullName, UpdateLinks:=False, IgnoreReadOnlyRecommended:=True)
End If
On Error GoTo 0
Set GetWorkbook = wbReturn
End Function

Related

Check if Workbook is opened by another user

I have a drop-down menu assigned to a shape, i use it to open others workbooks, but these are shared workbooks, so i want VBA to tell me when the workbook i selected are being used by another user and dont open it, because I need it to be opened in edit mode.
Menu:
My code so far:
Sub MenuSuspenso()
Application.CommandBars("Cell").Reset
Dim cbc As CommandBarControl
For Each cbc In Application.CommandBars("cell").Controls
cbc.Visible = False
Next cbc
With Application.CommandBars("Cell").Controls.Add(temporary:=True)
.Caption = "AQUAS"
.OnAction = "AQUAS"
End With
End Sub
Sub AQUAS()
Dim book As Workbook
Set book = "\\T\Public\DOCS\Hualley\FLUXO CAIXA HINDY - 111.xlsm"
If book.ReadOnly = True Then
MsgBox ("Arquivo em Uso")
book.Close()
app.Quit()
Else
Workbooks.Open ("\\T\Public\DOCS\Hualley\FLUXO CAIXA HINDY - 111.xlsm"), True
End Sub
The book comes from a server drive, and have links ( true for UpdateLinks ) and macros.
Please, try the next function. It or its other versions exist on internet from some years. I mean, I am not the one designing it, but I do not know where from I have it:
Function IsWorkBookOpen(FileName As String) As Boolean
Dim fileCheck As Long, ErrNo As Long
On Error Resume Next
fileCheck = FreeFile()
Open FileName For Input Lock Read As #fileCheck
Close fileCheck
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
Now, how to use it...
Firstly, this part of your code is wrong:
Dim book As Workbook
Set book = "\\T\Public\DOCS\Hualley\FLUXO CAIXA HINDY - 111.xlsm"
This should be declared as String, not being Set and check if the workbook is open in the next way:
Sub AQUAS()
Dim bookPath As String, bookWb As Workbook
bookPath = "\\T\Public\DOCS\Hualley\FLUXO CAIXA HINDY - 111.xlsm"
'check if its full name is correct:
If Dir(bookPath) = "" Then MsgBox "The supplied workbook name is wrong...": Exit Sub
If IsWorkBookOpen(bookPath) Then
MsgBox ("Arquivo em Uso")
Else
Set bookWb = Workbooks.Open(bookPath)
Debug.Print bookWb.Sheets.count 'it returns the number of sheets for the open workbook...
'Here do whatever you need with the workbook.
End If
End Sub

Code to add a sheet and rename that sheet

Code to add a sheet and rename that sheet from the user.
Sub tenloops1()
Worksheets.Add
Sheets(ActiveSheet.Name).Select = InputBox("Enter Sheet Name")
End Sub
I would do this slightly different to minimize the error that can happen when you are adding and naming a sheet.
Logic
You have to take care of the following
The sheet name is valid. i.e It is not an empty string or it is not more than 31 characters. Neither it should contain the characters /,\,[,],*,?,:
There should not be a sheet already with that name.
Error Handling On Error GoTo... to catch any other errors that may rise.
Code
Option Explicit
Sub Sample()
Dim Ret As Variant
On Error GoTo Whoa
'~~> Get user input
Ret = InputBox("Enter a valid sheet name")
If Ret = "" Then Exit Sub
'~~> Check if the sheet name is valid
If IsValidSheetName(Ret) = False Then
MsgBox "The sheet name cannot have length more than 31 " & _
"characters. Neither it can contain the characters /,\,[,],*,?,:"
Exit Sub
End If
'~~> Check if there is no other sheet with that name
If DoesSheetExist(Ret) Then
MsgBox "There is already a sheet with that name. Enter a new name"
Exit Sub
End If
'~~> Add the sheet and name it in one go
ThisWorkbook.Sheets.Add.Name = Ret
Exit Sub
Whoa:
MsgBox Err.Description
End Sub
Private Function IsValidSheetName(userinput As Variant) As Boolean
Dim IllegalChars As Variant
Dim i As Long
IllegalChars = Array("/", "\", "[", "]", "*", "?", ":")
If Len(userinput) > 31 Then Exit Function
For i = LBound(IllegalChars) To UBound(IllegalChars)
If InStr(userinput, (IllegalChars(i))) > 0 Then Exit Function
Next i
IsValidSheetName = True
End Function
Private Function DoesSheetExist(userinput As Variant) As Boolean
Dim wsh As Worksheet
On Error Resume Next
Set wsh = ThisWorkbook.Sheets(userinput)
On Error GoTo 0
If Not wsh Is Nothing Then DoesSheetExist = True
End Function
ActiveSheet.Name = InputBox("Enter Sheet Name")
and make sure the user does not enter any invalid characters.
You can also do it this way:
Sub tenloops1()
Dim ws As Worksheet
Dim sName as String
sName = InputBox("Enter Sheet Name")
' also may want to check for sName being a valid sheet name here
If Len(sName) > 0 Then
Set ws = Worksheets.Add()
ws.Name = sName
Else
' user clicked cancel
End If
End Sub
Structured example call
[1] Get user input
[2] Repeat in a loop if a sheet name is invalid or exists already
[3] Add sheet and name it
This approach doesn't pretend to be the best one, but you can profit from studying it, as it demonstrates an alternative approach in help functions b) and c)
Sub ExampleCall()
'~~~~~~~~~~~~~~~~~~~~~~~~~
'[1] Get user input
'~~~~~~~~~~~~~~~~~~~~~~~~~
Dim Sheetname As String
Sheetname = InputBox("Enter a valid sheet name or leave blank to exit.")
If Sheetname = vbNullString Then Exit Sub
'~~~~~~~~~~~~~~~~~~~~~~~~~
'[2] Check sheet validity (via help function SheetError()
'~~~~~~~~~~~~~~~~~~~~~~~~~
Do While SheetError(Sheetname, ThisWorkbook)
If Sheetname = vbNullString Then Exit Sub
Sheetname = InputBox("Enter a valid sheet name")
If StrPtr(Sheetname) = 0 Then MsgBox "Cancelled by user.": Exit Sub
Loop
'~~~~~~~~~~~~~~~~~~~~~~~~~
'[3] Add sheet and name it
'~~~~~~~~~~~~~~~~~~~~~~~~~
ThisWorkbook.Sheets.Add.Name = Sheetname
End Sub
Function SheetError()
Controls user inputs of sheet names in ExampleCall and uses two help functions b) and c)
Private Function SheetError(Sheetname As String, wb As Workbook, Optional ShowMsg As Boolean = True) As Boolean
'Purpose: check for possible sheet errors; return True if so
Dim msg As String
'a) Check sheet length
If Not Len(Sheetname) Or Len(Sheetname) > 31 Then
If ShowMsg Then msg = "The sheet name cannot be empty or have more than 31 characters." & vbNewLine
SheetError = True
End If
'b) Check if sheet already exists
If SheetExists(Sheetname, wb) Then
If ShowMsg Then msg = msg & "There is already a sheet with that name. Enter a new name!" & vbNewLine
SheetError = True
End If
'c) Check if the sheet name is valid
If IsValidSheetName(Sheetname) = False Then
If ShowMsg Then msg = msg & "The sheet name must not contain /,\,[,],*,?,: characters."
SheetError = True
End If
If SheetError And ShowMsg Then MsgBox msg, vbExclamation, "Sheet Error"
End Function
Help function b) SheetExists()
Allows a one line check:
Private Function SheetExists(Sheetname As String, wb As Workbook) As Boolean
'Purp.: check if sheet exists
'Date: 2021-03-08
'Auth.: https://stackoverflow.com/users/6460297/t-m
SheetExists = Not IsError(Application.Evaluate("'" & wb.Path & "\[" & wb.Name & "]" & Sheetname & "'!A1"))
End Function
Help function c) IsValidSheetName()
Compares a byte array (by) derived from sheetname characters with an array of illegal characters (illegalAsc) via Application.Match().
Note that
Match() isn't restricted to only 1 array argument!
(shows the 1-based positions of illegal occurrencies, non-findings error)
Count() ignores error elements, so it suffices to detect at least one occurrence of an element
The illegal characters not allowed in sheet names are /\[]*?:
Private Function IsValidSheetName(Sheetname As String) As Boolean
'Auth.: https://stackoverflow.com/users/6460297/t-m
'Purp.: check for valid sheet name
'Date: 2021-03-08
'a) length cannot exceed 31 characters
If Len(Sheetname) > 31 Then Exit Function
'b) define illegal character codes
Dim IllegalAsc As Variant
IllegalAsc = Array(47, 92, 91, 93, 42, 63, 58) ' i.e. /\[]*?:
'c) convert name to byte array
Dim by() As Byte: by = Sheetname
'd) return true if no counted occurrencies of illegal matches
With Application
IsValidSheetName = .Count(.Match(IllegalAsc, by, 0)) = 0 ' edited due to comment
End With
End Function
I am new to VBA and hope the code does what you want.
Sub tenloops1()
Worksheets.Add
ActiveSheet.Name = InputBox("Enter Sheet Name")
End Sub

Is it possible to loop through excel worksheets and run slightly different code on each one?

I would like to loop through 4 certain worksheets in a workbook.
Bulk of the code I am running is the same in each sheet.
I am also opening and linking different cells from other workbooks and these will be different on each sheet, hence why my code will be slightly different as it will change variables.
The problem I have is It's working but ignores the rest of my if statements except the first so doesn't run the way I want it to. Example below
Sub CompleteSummary()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim x As Workbook
Dim sht As Worksheet
Dim Sshts As Variant
Dim Ssht As Variant
Dim i As Integer
Set x = Workbooks.Open(s, ReadOnly:=True)
If Application.Calculation = xlCalculationAutomatic Then
Else: Application.Calculation = xlCalculationAutomatic
End If
Sshts = Array("First1", "Second1", "Third1", "Fourth1")
For i = 0 To UBound(Sshts)
Set sht = x.Worksheets(Sshts(i))
Debug.Print "print me " & Sshts(i)
If sht.Name = "First1" Then
Debug.Print "opened 1st"
ElseIf sht.Name = "Second1" Then
Debug.Print "opened 2nd"
ElseIf sht.Name = "Third1" Then
Debug.Print "opened 3rd"
ElseIf sht.Name = "Fourth1" Then
Debug.Print "opened 4th"
End If
Debug.Print "Complete"
Next i
The output result is as follows:
print me First1
opened 1st
Complete
print me Second1
Complete
print me Third1
Complete
print me Fourth1
Complete
What I would like it to do is this:
print me First1
opened 1st
Complete
print me Second1
opened 2nd
Complete
print me Third1
opened 3rd
Complete
print me Fourth1
opened 4th
Complete
As you can see it just takes the first if condition throughout the loop and ignores the rest despite it cycling through all of the sheets.
Any ideas or even if there is a better way than a loop and if conditions?
I think this would be an easier approach:
Dim wb As Workbook: Set wb = ThisWorkbook
Dim x As Workbook
Dim sht As Worksheet
Set x = Workbooks.Open(s, ReadOnly:=True)
Application.Calculation = xlCalculationAutomatic 'just do it...
For Each sht In x.Worksheets
Debug.Print "Checking: " & sht.Name
Select Case sht.Name
Case "First1": Debug.Print "opened 1st"
Case "Second1": Debug.Print "opened 2nd"
Case "Third1": Debug.Print "opened 3rd"
Case "Fourth1": Debug.Print "opened 4th"
End Select
Debug.Print "Done checking"
Next sht
For extra robustness compare the lower-cased names.
By your description you don't need an Ifs or Elses. Instead just call a sub that has the repetitive code and feed it arguments that make up the difference. Here is a schematic example.
Option Explicit
Sub CompleteSummary()
' 113
Dim Wb As Workbook
Dim WsName() As String
Dim i As Integer
If Application.Calculation = xlCalculationAutomatic Then
Application.Calculation = xlCalculationManual
Else
Application.Calculation = xlCalculationAutomatic
End If
Set Wb = ThisWorkbook
WsName = Split("First1,Second1,Third1,Fourth1", ",")
For i = 0 To UBound(WsName)
If DoTheWork(WsName(i)) Then Debug.Print "Complete"
Next i
Application.Calculation = xlCalculationAutomatic
End Sub
Private Function DoTheWork(WsName As String) As Boolean
' 113
On Error Resume Next
Debug.Print "Opened " & WsName
DoTheWork = (Err.Number = 0) ' no error occurred
Err.Clear
End Function
If there are different workbooks to be opened depending upon which worksheet is being worked on you can make this choice either in the main procedure or the sub. In the latter case you would pass 2 parameters instead of the one in my example. I think you could pass up to 255 arguments.
I developed the sub as a function which returns True or False depending upon whether the action was executed without error. You could also let the function return another value, such as the result of a calculation which is slightly different for each set of arguments and that you may use to continue whatever the Main procedure is doing.
Multiple Worksheets
I suspect what happened was that your last three worksheets had slightly different names i.e. their case was different.
The First Procedure CompleteSummary
The contents of the Sheet Names Array demonstrate the opposite of the previous case: the worksheet names are intentionally written in a different case to show that case doesn't matter when accessing a worksheet (or opening a workbook).
The use of the Opened Array allows us to avoid the If clause and therefore avoid checking the worksheet names.
With the With statements we can avoid using additional variables.
The first Debug.Print line will print the actual worksheet names and the names in the Sheet Names Array in parentheses.
The second Debug.Print line further shows how the If clause is avoided.
The Second Procedure StringCompare
When comparing strings where there might be a difference in case, you can use one of the ways presented in this procedure.
Most often I have seen the use of LCase or UCase, but I prefer StrComp whose only purpose is to compare two strings.
In your particular case, for all comparisons you could have e.g. used one of the following options:
If LCase(sht.Name) = LCase("First1") Then
If UCase(sht.Name) = UCase("First1") Then
If StrComp(sht.Name, "First1", vbTextCompare) = 0 Then
etc.
Additionally there is an option of using Option Compare Text right after Option Explicit i.e. before any procedure. Then you could safely use your solution without any changes.
The Code
Option Explicit
'Option Compare Text
Sub CompleteSummary()
Const wbPath As String = "F:\Test\2020\64688445\Test.xlsm"
Dim SheetNames As Variant
SheetNames = Array("FiRst1", "SecOnd1", "ThiRd1", "FouRth1")
Dim Opened As Variant
Opened = Array("1st", "2nd", "3nd", "4th")
Dim n As Long
With Workbooks.Open(Filename:=wbPath, ReadOnly:=True)
For n = LBound(SheetNames) To UBound(SheetNames)
With .Worksheets(SheetNames(n))
Debug.Print "print me " & .Name & " (" & SheetNames(n) & ")"
Debug.Print "opened " & Opened(n)
Debug.Print "Complete"
End With
Next n
' Since each workbook was only read from we can safely close it.
'.Close SaveChanges:=False
End With
End Sub
Sub StringCompare()
Debug.Print "Assign: ", "A" = "a"
Debug.Print "Like: ", "A" Like "a"
Debug.Print "StrComp0:", StrComp("A", "a") = 0
Debug.Print
Debug.Print "LCase: ", LCase("A") = LCase("a")
Debug.Print "UCase: ", UCase("A") = UCase("a")
Debug.Print "StrComp1:", StrComp("A", "a", vbTextCompare) = 0
Debug.Print "StrCpmvL:", StrConv("A", vbLowerCase) _
= StrConv("a", vbLowerCase)
Debug.Print "StrConvU:", StrConv("A", vbUpperCase) _
= StrConv("a", vbUpperCase)
Debug.Print
End Sub

Pass parameter from VbScript to vba function

I want to call a vba function from vbscript which has a parameter, I Know how to call a parameterized sub but having issue with function
Here is what I have tried, I tried the code here Calling vba function(with parameters) from vbscript and show the result , but this also didn't work, it gave an error as expected end of statement
Set xlObj = CreateObject("Excel.Application")
Set objWorkbook = xlObj.Workbooks.Open("E:\Headers.xlsm")
xlObj.Application.Visible = False
xlObj.Workbooks.Add
Dim result
result = xlObj.Application.Run("Headers.xlsm!Headers",filename)
xlFile.Close True
xlObj.Quit
this my vba function
Function Headers(filename As String) As String
Application.ScreenUpdating = False
Dim myWb As Workbook
Dim i As Integer
Dim flag As Boolean
Set myWb = Workbooks.Open(filename:=filename)
Dim arr
arr = Array("col1","col2")
For i = 1 To 2
If Cells(1, i).Value = arr(i - 1) Then
Headers = "True"
Else
Headers = "False , Not Found Header " & arr(i - 1)
Exit Function
End If
Next
myWb.Close
End Function
In your VBScript xlObj is set to be an application Set xlObj = CreateObject("Excel.Application"). That means xlObj.Application should be xlObj only.
In your VBScript Filename is not declared nor set to a value therefore it is empty. You need to define value to it.
Set xlObj = CreateObject("Excel.Application")
Set objWorkbook = xlObj.Workbooks.Open("E:\Headers.xlsm")
xlObj.Visible = False
xlObj.Workbooks.Add
Dim Filename 'declare filename and set a value to it
Filename = "E:\YourPath\Yourfile.xlsx"
Dim Result
Result = xlObj.Run("Headers.xlsm!Headers", Filename)
xlFile.Close True
xlObj.Quit
In your function you use Exit Function. This will stop the code immediately at this point, which means your workbook myWb will not be closed! It stays open because myWb.Close is never reached. Change Exit Function to Exit For to just exit the loop and continue to close the workbook.
Cells(1, i).Value is neither specified which workbook it is in nor which worksheet. This is not very reliable never call Cells or Range without specifying workbook and worksheet (or Excel will guess which one you mean, and Excel can fail if you are not precise).
Therfore I recommend to use something like myWb.Worksheets(1).Cells(1, i).Value if you always mean the first worsheet in that workbook. Alternatively if it has a defined name using its name would be more reliable: myWb.Worksheets("SheetName").Cells(1, i).Value
If you turn off ScreenUpdating don't forget to turn it on in the end.
Error handling in case filename does not exist would be nice to not break the function.
You can slightly improve speed by assuming Headers = "True" as default and just turn it False in case you find any non matching header. This way the variable is only set once to True instead of multiple times for every correct header.
Public Function Headers(ByVal Filename As String) As String
Application.ScreenUpdating = False
Dim flag As Boolean 'flag is never used! you can remove it
On Error Resume Next 'error handling here would be nice to not break if filename does not exist.
Dim myWb As Workbook
Set myWb = Workbooks.Open(Filename:=Filename)
On Error Goro 0 'always reactivate error reporting after Resume Next!!!
If Not myWb Is Nothing Then
Dim Arr() As Variant
Arr = Array("col1", "col2")
Headers = "True" 'assume True as default and just change it to False if a non matching header was found (faster because variable is only set true once instead for every column).
Dim i As Long 'better use Long since there is no benefit in using Integer
For i = 1 To UBound(arr) + 1 'use `ubound to find the upper index of the array, so if you add col3 you don't need to change the loop boundings
If Not myWb.Worksheets(1).Cells(1, i).Value = Arr(i - 1) Then 'define workbook and worksheet for cells
Headers = "False , Not Found Header " & Arr(i - 1)
Exit For '<-- just exit loop but still close the workbook
End If
Next i
Else
Headers = "File '" & Filename & "' not found!"
End If
Application.ScreenUpdating = True
myWb.Close
End Function

Accessing open workbook in a sub generates Error 1004 "Method of 'Sheets' of Object '_Global' not failed" sometimes

I am getting inconsistent results when I try to refer to an active workbook. About half the time I get the "Method of 'Sheets' of Object '_Global' not failed" error and other times the code works fine. I don't see a pattern.
The VBA code is part of a Word document that allows the user to open a template Excel file and select/copy text from the Word doc into rows on the Excel file.
In a previous sub I successfully open an Excel template file (I call it a RTM template). In the code below I want to activate the "RTM" worksheet, select the first cell where the template could already have data in it from a previous execution and if there is, then count how many rows of data exist. In this way the new data will be posted in the first row which does not have any data. I am using named ranges in my Workbook to refer to the starting cell ("First_Cell_For_Data").
When I run my code sometimes it runs without error and other times it stops on the "Sheets("RTM").Activate" and gives me the "Method...." error. The same result occurs when I change the variable definition of wb_open to Object. I have also tried using "wb_open.Sheets("RTM").Activate" with the same results.
As suggested in the comments below I added "If wb_open is nothing ...." to debug the issue. I also added the sub List_Open_Workbooks which enumerates the open workbooks (of which there is only 1) and activates the one that matches the name of the one with the correct filename. This is successful. But upon returning to Check_Excel_RTM_Template I still get the Method error on the "Sheets("RTM").Activate" line.
Second Update: after more time diagnosing the problem (which still occurs intermittently) I have added some code that may help getting to the root of the problem. In the "List_Open_Workbooks" sub I test for xlApp.Workbooks.Count = 0. So all references to an open Excel workbook will fail. At this point my template workbook is open in Windows. Am I drawing the correct conclusion?
Third Update: I tried Set wb_open = GetObject(str_filename) where str_filename contains the name of the Excel template file I just opened.
I get the following error message.
Also, I noticed that if I start with a fresh launch of Word and Excel it seems to run just fine.
Sub Check_Excel_RTM_Template(b_Excel_File_Has_Data As Boolean, i_rows_of_data As Integer)
Dim i_starting_row_for_data As Integer
Dim wb_open As Object
Set wb_open = ActiveWorkbook
i_rows_of_data = 0
If wb_open Is Nothing Then
MsgBox "RTM Workbook not open in Check_Excel_RTM_Template"
Call List_Open_Workbooks(b_Excel_File_Has_Data, i_rows_of_data)
Else
' On Error GoTo Err1:
' Sheets("RTM").Activate
' range("First_Cell_For_Data").Select
Workbooks(wb_open.Name).Worksheets("RTM").range("First_Cell_For_Data").Select
If Trim(ActiveCell.Value) <> "" Then
b_Excel_File_Has_Data = True
Do Until Trim(ActiveCell.Value) = ""
ActiveCell.Offset(1, 0).Select
i_rows_of_data = i_rows_of_data + 1
Loop
Else
b_Excel_File_Has_Data = False
End If
End If
Exit Sub
Err1:
MsgBox getName(str_Excel_Filename) & " is not a RTM template file."
b_abort = True
End Sub
Sub to enumerate all open workbooks
Sub List_Open_Workbooks(b_Excel_File_Has_Data As Boolean, i_rows_of_data As Integer)
Dim xlApp As Excel.Application
Set xlApp = GetObject(, "Excel.Application")
Dim str_filename As String
Dim xlWB As Excel.Workbook
If xlApp.Workbooks.Count = 0 Then
MsgBox "Error: Windows thinks there are no workbooks open in List_Open_Workbooks"
b_abort = True
Exit Sub
End If
For Each xlWB In xlApp.Workbooks
Debug.Print xlWB.Name
str_filename = getName(str_Excel_Filename)
If Trim(xlWB.Name) = Trim(str_filename) Then
xlWB.Activate
If xlWB Is Nothing Then
MsgBox "Workbook still not active in List_Open_Workbooks"
b_abort = True
Exit Sub
Else
' Sheets("RTM").Activate
Workbooks(xlWB.Name).Worksheets("RTM").range("First_Cell_For_Data").Select
range("First_Cell_For_Data").Select
If Trim(ActiveCell.Value) <> "" Then
b_Excel_File_Has_Data = True
Do Until Trim(ActiveCell.Value) = ""
ActiveCell.Offset(1, 0).Select
i_rows_of_data = i_rows_of_data + 1
Loop
Else
b_Excel_File_Has_Data = False
End If
End If
End If
Next xlWB
Set xlApp = Nothing
Set xlWB = Nothing
End Sub
Function to extract filename from path/filename
Function getName(pf)
getName = Split(Mid(pf, InStrRev(pf, "\") + 1), ".")(0) & ".xlsx"
End Function
I am hoping I found the source of my problem and solved it.
I believe that referring to an open workbook in sub using Dim wb_open As Object & Set wb_open = ActiveWorkbook in the Check_Excel_RTM_Template sub is causing my inconsistent problems....perhaps this is an anomoly (bug) in the VBA implementation in Word.
In the revised code I posted below I am passing the o_Excel object from the calling routine and using oExcel.Activesheet.xxx to reference ranges and values.
Now I next problem is that I am having errors on the form control button code which also uses the Dim wb_open As Object & Set wb_open = ActiveWorkbook approach to referring to the open workbook. But I'll post that as a new question.
Thanks to all who commented and provided suggestions.
Sub Check_Excel_RTM_Template(oExcel As Object)
Dim i_starting_row_for_data As Integer
Dim str_filename As String
i_rows_of_data = 0
On Error GoTo Err1:
oExcel.ActiveSheet.range("First_Cell_For_Data").Select
If Trim(oExcel.ActiveCell.Value) <> "" Then
b_Excel_File_Has_Data = True
Do Until Trim(oExcel.ActiveCell.Value) = ""
oExcel.ActiveCell.Offset(1, 0).Select
i_rows_of_data = i_rows_of_data + 1
Loop
Else
b_Excel_File_Has_Data = False
End If
Exit Sub
Err1:
Documents(str_doc_index).Activate
MsgBox getName(str_Excel_Filename) & " is not a RTM template file."
b_abort = True
End Sub

Resources