I have a small Excel-macro which opens a visio-file. With Excel 2010 everything worked fine. Now I've installed Office 2016 and tried the same excel-macro and it won't work.
There is no exception, but I see that my variable "VisioDoc" is empty.
Do you have any ideas where the Problem could be?
Sub cmdChooseFile_Click()
'...do something
Set VisioDoc = openDocument(filepath)
If VisioDoc Is Nothing Then
MsgBox "boom, didn't work!", vbExclamation
Exit Sub
End If
End Sub
Private Function openDocument(docPath As String) As Visio.Document
visioOpened = True
Application.StatusBar = "Lade Visiodokument..."
On Error Resume Next
Set VisioApp = GetObject(, "Visio.Application")
If VisioApp Is Nothing Then
Set VisioApp = CreateObject("Visio.Application")
VisioApp.Visible = False
visioOpened = False
End If
Set openDocument = VisioApp.Documents.Open(docPath)
Application.StatusBar = False
End Function
Related
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
I have a problem with a Excel VBA code that constantly get stuck in 'running' when I execute the code, see figure
The Purpose of the code is:
Log into SAP
Execute a transaction (in this case IW73)
Export a Spreadsheet as .txt
The Problem after closing the SAP session the Excel get stuck in "Running". We have tried running it on different computers with the same (Stuck in 'Running') error.
Code:
Sub Logontrial()
Dim SapGuiApp As Object
Dim oConnection As Object
Dim SAPCon As Object, SAPSesi As Object
Dim SapGuiAuto As Object, SAPApp As Object
If SapGuiApp Is Nothing Then
Set SapGuiApp = CreateObject("Sapgui.ScriptingCtrl.1")
End If
If oConnection Is Nothing Then
Set oConnection = SapGuiApp.OpenConnection("5.1.1 AP1 ERP Production", True)
End If
If SAPSesi Is Nothing Then
Set SAPSesi = oConnection.Children(0)
End If
Application.DisplayAlerts = False
With SAPSesi
SAPSesi.findById("wnd[0]/usr/txtRSYST-MANDT").Text = "500"
SAPSesi.findById("wnd[0]/usr/txtRSYST-BNAME").Text = "UserName"
SAPSesi.findById("wnd[0]/usr/pwdRSYST-BCODE").Text = "Password"
SAPSesi.findById("wnd[0]/usr/txtRSYST-LANGU").Text = "EN"
SAPSesi.findById("wnd[0]/usr/txtRSYST-LANGU").SetFocus
SAPSesi.findById("wnd[0]/usr/txtRSYST-LANGU").caretPosition = 2
SAPSesi.findById("wnd[0]").sendVKey 0
' start extraction
On Error GoTo Resume1
' DoEvents
SAPSesi.findById("wnd[0]").maximize
SAPSesi.findById("wnd[0]/tbar[0]/okcd").Text = "/nIW73"
SAPSesi.findById("wnd[0]").sendVKey 0
SAPSesi.findById("wnd[0]/usr/ctxtSWERK-LOW").Text = "GB10"
SAPSesi.findById("wnd[0]/usr/ctxtSWERK-LOW").SetFocus
SAPSesi.findById("wnd[0]/usr/ctxtSWERK-LOW").caretPosition = 4
SAPSesi.findById("wnd[0]").sendVKey 8
SAPSesi.findById("wnd[0]").sendVKey 0
SAPSesi.findById("wnd[0]/mbar/menu[0]/menu[11]/menu[2]").Select
SAPSesi.findById("wnd[1]/usr/subSUBSCREEN_STEPLOOP:SAPLSPO5:0150/sub:SAPLSPO5:0150/radSPOPLI-SELFLAG[1,0]").Select
SAPSesi.findById("wnd[1]/usr/subSUBSCREEN_STEPLOOP:SAPLSPO5:0150/sub:SAPLSPO5:0150/radSPOPLI-SELFLAG[1,0]").SetFocus
SAPSesi.findById("wnd[1]/tbar[0]/btn[0]").press
SAPSesi.findById("wnd[1]/usr/ctxtDY_FILENAME").Text = "DataImport1.txt"
SAPSesi.findById("wnd[1]/usr/ctxtDY_FILENAME").caretPosition = 15
SAPSesi.findById("wnd[1]/tbar[0]/btn[11]").press
SAPSesi.findById("wnd[0]/tbar[0]/okcd").Text = "/n"
SAPSesi.findById("wnd[0]").sendVKey 0
Set SAPSesi = Nothing
Set oConnection = Nothing
Set SapGuiApp = Nothing
End With
' This part after closing the SAP session it get stuck.
Resume1:
Application.DisplayAlerts = True
Set SAPSesi = Nothing
Set oConnection = Nothing
Set SapGuiApp = Nothing
Exit Sub
End Sub
Thanks in advance
//Patrick
Disclaimer: This is not quality code, and most probably one day someone can put some bunch of hate towards you.
Before finding something better, try the following, it should work. Simply write End here:
Set SAPSesi = Nothing
Set oConnection = Nothing
Set SapGuiApp = Nothing
End
Then look for a better solution.
I created a macro in Excel 2010, that works quite fine when called from the Macros dialog or the VB window. All's fine at that point. Now, I tried my hand at customized ribbons, and used Custom UI Editor to create a new tab, with custom icons to call my macro. And it's not fine.
The call to the macro works, the macro seems to run properly, scanning each sheet as it should, looking for comments and acting on them, but when it's completed, almost none of the comments were modified as they should have been.
And that's my issue: when I run the macro "normally", it works as planned, it's only when I try to call it from its custom icon that it doesn't do what it's supposed to do (while still seeming to when clicked).
Anyone has an idea what could be wrong?
I don't think it's the code, as I said, it works fine when called from Macros or the VB window
Edit: As I said, I don't think the code is the problem, as it executes without error (it just doesn't do what it's supposed to), but as requested, I post it here:
Sub ImportCommentsFromWord(control As IRibbonControl)
Dim xComment As Comment
Dim xSheet As Worksheet
Dim wApp As Object
'Opens Word if not already open
On Error Resume Next
Set wApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
Err.Clear
Set wApp = CreateObject("Word.Application")
End If
wApp.Visible = False
For Each xSheet In ActiveWorkbook.Worksheets
'Activates each sheet one after another
xSheet.Activate
sName = xSheet.Name
expName = Application.ActiveWorkbook.Path + "\" + sName + ".docx"
'Checks if there are comments in active sheet
For Each xComment In xSheet.Comments
CommsInSheet = 1
Next
If CommsInSheet = 1 Then
'Opens the translated document to import comments into the sheet
wApp.Documents.Open (expName)
wApp.Selection.ClearFormatting
wApp.Selection.Find.MatchWildcards = False
wApp.Selection.WholeStory
wApp.Selection.MoveLeft
FileEnd = 0
'Imports comments until end of file is reached
While FileEnd = 0
wApp.Selection.ExtendMode = True
wApp.Selection.MoveRight
With wApp.Selection.Find
.Text = "^l"
End With
wApp.Selection.Find.Execute
DestCell = Mid(wApp.Selection.Text, 2, Len(wApp.Selection.Text) - 2)
wApp.Selection.ExtendMode = False
wApp.Selection.MoveRight
wApp.Selection.ExtendMode = True
With wApp.Selection.Find
.Text = "^l"
End With
wApp.Selection.Find.Execute
wApp.Selection.ExtendMode = False
DestComm = Left(wApp.Selection.Text, Len(wApp.Selection.Text) - 1)
wApp.Selection.MoveRight
wApp.Selection.MoveLeft
wApp.Documents.Add DocumentType:=0
wApp.Selection.Text = DestComm
With wApp.Selection.Find
.Text = "^p"
.Replacement.Text = Chr(10)
End With
wApp.Selection.Find.Execute Replace:=wdReplaceAll
wApp.Selection.WholeStory
DestComm = Left(wApp.Selection.Text, Len(wApp.Selection.Text) - 1)
wApp.ActiveDocument.Close savechanges:=False
If Right(DestComm, 11) = "END_OF_FILE" Then
DestComm = Left(DestComm, Len(DestComm) - 11)
FileEnd = 1
End If
xSheet.Range(DestCell).Comment.Text Text:=DestComm
Wend
'Closes the Word document
wApp.ActiveDocument.Close savechanges:=False
End If
CommsInSheet = 0
Next
wApp.Visible = True
Set wApp = Nothing
End Sub
Never mind, I found the solution myself: the issue was in the xml code of the customized ribbon, it was calling the wrong macro, so of course it didn't work as expected...
what is wrong with the following code?, Every time I run it I get a "Run-Time Error 91, Object variable or with black variable not set"
Private Sub Document_Open()
Dim workBook As workBook
Application.ScreenUpdating = True
Set workBook = Workbooks.Open("Z:\Credit_Check_DB.xls", True, True)
txtCompany1.Value = workBook.Worksheets("Sheet2").Range("A1").Formula
txtCompany2.Value = workBook.Worksheets("Sheet2").Range("A1").Formula
txtCityState1.Value = workBook.Worksheets("Sheet2").Range("C1").Formula
txtCityState2.Value = workBook.Worksheets("Sheet2").Range("C1").Formula
txtDate1.Value = workBook.Worksheets("Sheet2").Range("F1").Value
txtAddress1.Value = workBook.Worksheets("Sheet2").Range("B1").Formula
txtZip1.Value = workBook.Worksheets("Sheet2").Range("D1").Formula
txtPO.Value = "Purchase Order#: " & workBook.Worksheets("Sheet2").Range("I1").Formula
txtRec.Value = workBook.Worksheets("Sheet2").Range("K1").Formula
workBook.Close False
Set workBook = Nothing
Application.ScreenUpdating = True
Close_Excel
End Sub
Private Sub Close_Excel() 'closes excel application.
Dim Excel As Excel.Application
Dim ExcelOpened As Boolean
ExcelOpened = False
On Error Resume Next
Set Excel = GetObject(, "Excel.Application")
If Excel Is Nothing Then
Set Excel = New Excel.Application
ExcelOpened = True
End If
On Error GoTo 0
With Excel
If ExcelOpened Then
.Visible = True
.Workbooks.Add
End If
.ActiveWorkbook.Close False ***<-***!!!!!Debugger points to here!!!!!******
.Quit
End With
End Sub
any idea what is wrong with my code? I am basically pulling information from Excel into word.
Maybe Excel does not point to any Excel application (something went wrong, but you skipped the error), so ActiveWorkbook points to nothing. You should put On Error GoTo 0 immediately after GetObject.
I have already checked Tools > Options > General > Error Trapping in VBE - I have set it to both "Break in Class Module" and "Break on Unhandled Errors" and either way it still throws the error. The error is thrown on the line:
Set xlContacts = Workbooks(LocalContactsFilename)
It throws an error saying the subscript is out of range, and I understand that this means the index was not found within the Workbooks collection, this statement is here because usually the file is already open as an addin so I can just get a reference to it through this statement. It is supposed to resume on this error because if the file is not open I open it.
One odd thing I noticed about this- even though this line of code is not accessing any remote files or the network, it only throws this error when I am disconnected from the network. If I open the workbook while connected to the network this error is not thrown.
Has anyone experienced this before? When your options are set to only halt on unhandled exceptions but it halts anyways?
Public Sub openContactsFile()
On Error Resume Next
Dim fso As New FileSystemObject
Dim LocalContactsPath As String
Dim LocalContactsFilename As String
Dim LocalContactsShortFilename As String
LocalContactsPath = wbMyCompanyWorkbook.Names("localContactsPath").RefersToRange.Value
LocalContactsFilename = Mid(LocalContactsPath, (InStrRev(LocalContactsPath, "\") + 1))
LocalContactsShortFilename = Mid(LocalContactsFilename, 1, (InStrRev(LocalContactsFilename, ".") - 1))
'On Error Resume Next
Application.ScreenUpdating = False
If Not fso.FileExists(LocalContactsPath) Then
If MsgBox("The contacts file is not available. Click Yes to update the contacts now, or No to use the workbook without contact auto-fill capability.", vbYesNo, ThisWorkbook.NAME) = vbYes Then
SyncContacts
Else
GoTo cancelParse
End If
End If
If fso.FileExists(LocalContactsPath) Then
On Error GoTo catch_no_remote_connection
If fso.GetFile(LocalContactsPath).DateLastModified < fso.GetFile(wbMyCompanyWorkbook.Names("remoteContactsPath").RefersToRange.Value).DateLastModified Then
If MsgBox("Your local contacts file appears to be out of date, would you like to download the latest contacts file?", vbYesNo Or vbQuestion, ThisWorkbook.NAME) = vbYes Then
SyncContacts
End If
End If
catch_no_remote_connection:
If Err.Number = 53 Then Err.CLEAR
On Error Resume Next
Set xlContacts = Workbooks(LocalContactsFilename)
If xlContacts Is Nothing Then
Set xlContacts = Workbooks.Open(LocalContactsPath, False, True)
End If
xlContacts.Sheets(1).Range("A1:CN2000").Sort Key1:=xlContacts.Sheets(1).Range("F2"), Order1:=xlAscending, Key2:=xlContacts.Sheets(1).Range("B2"), Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal
End If
'hide the contacts from view or editing
On Error Resume Next
If Not Workbooks(LocalContactsFilename) Is Nothing Then xlContacts.IsAddin = True
Err.CLEAR
On Error GoTo 0
cancelParse:
Application.ScreenUpdating = True
Exit Sub
End Sub
Thanks in advance for any help with this!
I have had the same (unbelievably frustrating, as far as I can tell inexplicable) problem as you have, but in a different context. I find the best thing to do is to find a work-around. Instead of using error handling as you have, use this instead:
Dim wb As Workbook, _
xlContacts As Workbook
For Each wb In Application.Workbooks
If wb.Name = LocalContactsFilename Then
Set xlContacts = wb
Exit For
End If
Next wb
If xlContacts Is Nothing Then
Set xlContacts = Workbooks.Open(LocalContactsPath, False, True
End If
I would've preferred to code it the way you've done, but it seems there's no choice.
#TimWilliams
Thank you for the answer- I assumed Err.CLEAR resets the error handling but it does not. The code below functions correctly whether connected to the network or not (which I realize now was the origin of the problem), the problem was when it threw the file not found error and went to catch_no_remote_connection, there was no resume to clear the error, so I added this to close out the error handling block and reset the handler:
Resume post_err
post_err:
Functional Code:
Public Sub openContactsFile()
On Error Resume Next
Dim fso As New FileSystemObject
Dim LocalContactsPath As String
Dim LocalContactsFilename As String
Dim LocalContactsShortFilename As String
LocalContactsPath = wbMyCompanyWorkbook.Names("localContactsPath").RefersToRange.Value
LocalContactsFilename = Mid(LocalContactsPath, (InStrRev(LocalContactsPath, "\") + 1))
LocalContactsShortFilename = Mid(LocalContactsFilename, 1, (InStrRev(LocalContactsFilename, ".") - 1))
Application.ScreenUpdating = False
If Not fso.FileExists(LocalContactsPath) Then
If MsgBox("The contacts file is not available. Click Yes to update the contacts now, or No to use the workbook without contact auto-fill capability.", vbYesNo, ThisWorkbook.NAME) = vbYes Then
SyncContacts
Else
GoTo cancelParse
End If
End If
If fso.FileExists(LocalContactsPath) Then
On Error GoTo catch_no_remote_connection
If fso.GetFile(LocalContactsPath).DateLastModified < fso.GetFile(wbMyCompanyWorkbook.Names("remoteContactsPath").RefersToRange.Value).DateLastModified Then
If MsgBox("Your local contacts file appears to be out of date, would you like to download the latest contacts file?", vbYesNo Or vbQuestion, ThisWorkbook.NAME) = vbYes Then
SyncContacts
End If
End If
catch_no_remote_connection:
'there is no network connection, clear the error and resume from here
Err.CLEAR
Resume post_err
post_err:
On Error Resume Next
'get reference to the workbook if it is already open
Set xlContacts = Workbooks(LocalContactsFilename)
If xlContacts Is Nothing Then
'the workbook was not open, open it
Set xlContacts = Workbooks.Open(LocalContactsPath, False, True)
End If
'sort contacts by company, name
xlContacts.Sheets(1).Range("A1:CN2000").Sort Key1:=xlContacts.Sheets(1).Range("F2"), Order1:=xlAscending, Key2:=xlContacts.Sheets(1).Range("B2"), Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal
End If
'hide the contacts from view or editing by setting the workbook as an Addin
On Error Resume Next
If Not Workbooks(LocalContactsFilename) Is Nothing Then xlContacts.IsAddin = True
Err.CLEAR
On Error GoTo 0
cancelParse:
Application.ScreenUpdating = True
Exit Sub
End Sub
Thank you all for taking the time to look at this!