Excel is waiting for another application to complete an OLE action - vba

Before you go for the obvious: Application.DisplayAlerts = False has not solved my problem.
I have written a VBA procedure (initiated in Excel 2010) which loops around an array containing different Excel files. The loop opens the file, refreshes the data, saves and closes the file for each item in the array. I have written an error catch sub routine so I log which excel files have failed to open/refresh/save etc so a user can manually check them.
Some files are quite large and involve a large amount of data moving across the network; sometimes I get a dialog box with: Excel is waiting for another application to complete an OLE action.
I could use Application.DisplayAlerts = False to disable the message but this would presumably disable all alerts so I couldn't catch the errors?
Further I have tested using the line and it doesn't stop the dialog box pop-up. If I press enter it carries on but will likely pop-up again a few minutes later.
Is there a way to stop is message specifically without stopping other alerts?
NB. My process has a control instance of Excel which runs the VBA and opens the workbooks to be refreshed in a separate instance.
Thanks for your help
An extract of my code is below which contains the refresh elements
Sub Refresh_BoardPivots_Standard()
' On Error GoTo Errorhandler
Dim i
Dim errorText As String
Dim x
Dim objXL As Excel.Application
Set objXL = CreateObject("Excel.Application")
GetPivotsToRefresh ' populate array from SQL
For Each i In StandardBoardPiv
DoEvents
'If File_Exists(i) Then
If isFileOpen(i) = True Then
errorText = i
Failed(failedIndex) = errorText
failedIndex = failedIndex + 1
Else
objXL.Visible = True 'False
objXL.Workbooks.Open FileName:=i
If objXL.ActiveWorkbook.ReadOnly = False Then
BackgroundQuery = False
Application.DisplayAlerts = False
objXL.ActiveWorkbook.RefreshAll
objXL.Application.CalculateFull
objXL.Application.DisplayAlerts = False
objXL.ActiveWorkbook.Save
objXL.Application.DisplayAlerts = True
objXL.Quit
Else
errorText = i
Failed(failedIndex) = errorText
failedIndex = failedIndex + 1
objXL.Application.DisplayAlerts = False
objXL.Quit
Application.DisplayAlerts = True
End If
End If
' Else
' errorText = i
' Failed(failedIndex) = errorText
' failedIndex = failedIndex + 1
' End If
DoEvents
If Ref = False Then
Exit For
End If
Next i
Exit Sub
'Errorhandler:
'
'errorText = i
'Failed(failedIndex) = errorText
'failedIndex = failedIndex + 1
'Resume Next
End Sub

"Waiting for another application to complete an OLE action" isn't an alert message you can just turn off and forget, sometimes the macro will be able to continue on after, but in my experience if you are getting that error its only a matter of time until the problem crashes/freezes your whole macro so it should definitely be troubleshot and corrected.
I only get that error when I am using additional Microsoft Office Applications (other than the Excel that is running the code) as objects and one of them has an error- the Excel running the code doesn't know that an error occurred in one of the other applications so it waits and waits and waits and eventually you get the "Waiting for another application to complete an OLE action" message...
So to troubleshoot this sort of problem you got to look for the places you use other MSO apps... In your example, you have an additional instance of Excel and you are pulling data from Access, so its most likely one of those two that is causing the problems...
Below is how I would re-write this code, being more careful with where the code interacts with the other MSO apps, explicitly controlling what is happening in them.. The only piece I couldn't really do much is GetPivotsToRefresh because I cant see what exactly youre doing here, but in my code I just assumed it returned an array with a list of the excel files you want to update. See code below:
Sub Refresh_BoardPivots_Standard()
Dim pivotWB As Workbook
Dim fileList() As Variant
Dim fileCounter As Long
Application.DisplayAlerts = False
fileList = GetPivotsToRefresh 'populate array from SQL
For fileCounter = 1 To UBound(fileList, 1)
Set pivotWB = Workbooks.Open(fileList(fileCounter, 1), False, False)
If pivotWB.ReadOnly = False Then
Call refreshPivotTables(pivotWB)
pivotWB.Close (True)
Else
'... Error handler ...
pivotWB.Close (False)
End If
Next
End Sub
Public Sub refreshPivotTables(targetWB As Workbook)
Dim wsCounter As Long
Dim ptCounter As Long
For wsCounter = 1 To targetWB.Sheets.Count
With targetWB.Sheets(wsCounter)
If .PivotTables.Count > 0 Then
For ptCounter = 1 To .PivotTables.Count
.PivotTables(ptCounter).RefreshDataSourceValues
Next
.Calculate
End If
End With
Next
End Sub
So I created my own 'refreshPivotTables' but you could have embedded that into the master sub, I just thought the loops and loop counters might get a little messy at that point...
Hope this helps,
TheSilkCode

Related

VBA to open Excel file, refresh bloomberg data, save, close

I'm trying to write a vba script that gets called in a batch file to open an excel file, refresh bloomberg data, save the file, and then quit excel.
There was a historical question which asked something similar, but the suggested answer didn't seem to work - I can open the file and refresh the data, but it doesn't save the file or close excel.
I tried also putting in as a macro with the workbook_open file, but then ran into a problem where excel is saving and closing the file before refreshing the data. Any suggestions would be much appreciated.
Immediately below is the modified vba code that refreshes the data, but doesn't save or close the excel workbook.
'Write Excel.xls Sheet's full path here
strPath = "C:\MngXL\testbook.xlsm"
'Create an Excel instance and set visibility of the instance
Set objApp = CreateObject("Excel.Application")
objApp.Visible = True
Set wbToRun = objApp.Workbooks.Open(strPath)
StartAutomation
DoneNow
Sub StartAutomation()
Dim oAddin
Set oAddin = objApp.Workbooks.Open("C:\blp\API\Office Tools\BloombergUI.xla")
If Not oAddin Is Nothing Then
objApp.DisplayAlerts = False
objApp.Calculate
objApp.Run "RefreshAllStaticData"
objApp.Calculate
objApp.Run "RefreshAllStaticData"
'WaitTillUpdateComplete
End If
dim count
dim updated
updated = false
for count = 0 to 12
if updated = false then
if objApp.WorksheetFunction.CountIf(objApp.Range("rng_inWorkbook"),"#N/A Requesting Data...") = 0 Then
updated = true
else
Application.OnTime Now + TimeValue("00:00:15"), WaitTillUpdateComplete
end if
end if
next
End Sub
Private Sub WaitTillUpdateComplete()
Dim t
t = 0
objApp.Calculate
If objApp.WorksheetFunction.CountIf(objApp.Range("rng_inWorkbook"),"#NAME?") > 0 Then
Application.OnTime Now + TimeValue("00:00:15"), "WaitTillUpdateComplete"
ElseIf objApp.WorksheetFunction.CountIf(objApp.Range("rng_inWorkbook"),"#N/A") > 0 Then
Application.OnTime Now + TimeValue("00:00:15"), "WaitTillUpdateComplete"
ElseIf objApp.WorksheetFunction.CountIf(objApp.Range("rng_inWorkbook"),"#N/A Requesting Data...") > 0 Then
If t < 5 Then
t = t+ 1
waitlonger
Else
Exit Sub
End If
Else
Exit Sub
End If
End Sub
Sub waitlonger()
Dim x
x = Now + TimeValue("00:00:40")
Do While x > Now
Loop
objApp.Calculate
End Sub
Sub DoneNow()
wbToRun.Save
wbToRun.Close
objApp.DisplayAlerts = False
objApp.Quit
MsgBox strPath & " " & strMacro & " macro and .vbs successfully completed!!!!", vbInformation
End Sub
You need a strategy to let the refresh of Bloomberg data take about the right amount of time.
Currently, your program seems to allow only certain small amounts of time to pass with no feedback. Instead, you need to make a loop that cycles once every 10 seconds (or whatever makes sense) and checks to see if the program is done.
I like to do it this way:
dim count as integer
dim updated as boolean
updated = false
for count = 1 to 12 'or any value you choose
if updated = false then
if objApp.WorksheetFunction.CountIf(objApp.Range("rng_inWorkbook"),"#NAME?") = 0 Then
updated = true
else
Application.OnTime Now + TimeValue("00:00:15"), "WaitTillUpdateComplete"
end if
end if
next

Inconsistent error when moving worksheet

The code below is a function to move a worksheet in a workbook. It gets called from a userform that contains a listbox that lists the worksheets in the workbook. The input is an integer that gives the direction which to move the sheet. Left/right in workbook is up/down in the userform listbox, and the userform has up and down buttons that calls the function with different input (+1 for moving right and -2 for moving left).
This function sometimes gives the error Method 'Move' if object '_Worksheeet' failed, but not consistently. Mostly the error comes when moving a sheet a second time, so that I am not able to move a sheet more than once. Once the error occurs I am not able to move the sheet again. I can, however, select a different sheet and move this once before the same thing occurs.
If I implement a message box in the error handling, the behaviour changes. After closing the message box upon error, I can proceeed to move the same sheet again after an error. With a message box I can therefore move a sheet as many times as I want, but it only moves on every other button press. I guess the message box breaks code execution, which for some reason makes the function work again even one the same sheet that gave the error. I have tried replacing the message box with a delay or a selfclosing infobox but this does not give the same result.
To further complicate matters, sometimes when I open the userform application, the move buttons work perfectly without any error. I think this happens when the worksheet is already open before the application is opened.
It all seems very inconsistent, and beyond my knowledge. Any help or suggestions much appreciated.
Function FlyttMåling(Retning As Integer) As Boolean
Application.EnableEvents = False
Application.ScreenUpdating = False
'code to reference the correct workbook based on outside parameters
Dim wb As Workbook, ws As Worksheet
FlyttMåling = True
If Hovedvindu.LuftlydKnapp.Value = True Then
Set wb = ÅpneBok(1)
ElseIf Hovedvindu.TrinnlydKnapp.Value = True Then
Set wb = ÅpneBok(2)
End If
'sets variable to the index of sheet to be moved, chosen from list in userform
Dim nummer As Integer
Set ws = wb.Sheets(1)
If Hovedvindu.MålingerFrame.Liste.ListIndex < 0 Then
Exit Function
Else
Set ws = wb.Sheets(Hovedvindu.MålingerFrame.Liste.Value)
End If
nummer = ws.Index
'exit function if trying to move first sheet to the left or last sheet to the right
If (Retning = 1 And nummer = wb.Sheets.count) Or (Retning = -2 And nummer = 2) Then
Exit Function
End If
'code that moves worksheet
ws.Activate
On Error GoTo errHandler:
errResume:
ws.Move after:=wb.Sheets(nummer + Retning) 'THIS LINE CAUSES ERROR
On Error GoTo 0
Call oppdaterListe
'reselect the moved worksheet in the userform list
For i = 0 To Hovedvindu.MålingerFrame.Liste.ListCount - 1
If ws.Name = Hovedvindu.MålingerFrame.Liste.List(i) Then
Hovedvindu.MålingerFrame.Liste.Selected(i) = True
Exit For
End If
Next i
Application.EnableEvents = True
Application.ScreenUpdating = True
Exit Function
'error handling just sets the return to false to notify failure to move sheet
errHandler:
FlyttMåling = False
End Function
Found a workaround for this problmem. Changing the wb.move to a wb.copy, and then deleting the old sheet and renaming the copy to the name of the original sheet makes this code work as intended.

Remotely deactivate an excel file via vba

I would like to know if there is a way to remotely deactivate an excel file via vba.
The problem:
My company uses an excel file for sales to provide quotations to the customer. Now when there is an update to our pricing scheme I send a new version of the Excel file to the sales team. The obvious thing that happens next is that they don't use the most current version of the file to give a quote => the customer gets a wrong price.
What I tried so far:
I implemented a time bomb that lets the file expire at a defined date. The problem with this is that updates to the excel file happen irregularly.
What I have in mind:
Once the excel file starts a VBA script queries a web server for the most current version number. If the version number in the currently opening Excel file is lower than the one provided by the server, the file locks up.
Is this something one can realize with Excel and VBA? I could imagine that this causes some problem with Windows Security etc. because it may look like a trojan or virus.
You help is much appreciated!
If you send them an .xlsm file the following code (courtesy of Tom Urtis from "VBA and Macros for Microsoft Excel"), will delete the file, when the chosen date has passed.
Please be careful with this code and always make sure to have a back-up copy saved.
Paste this sub in the "workbook" section of the vba and it is going to execute every single time the file is opened. If the current date is after the chosen date it will delete the file.
Private Sub workbook_open()
If Date > CDate("13.07.16") Then
With ThisWorkbook
.Saved = True
.ChangeFileAccess xlReadOnly
Kill .FullName
.Close False
End With
End If
End Sub
You can also inspect but not by date, by file version, referring to the cell in which version will be available.
Private Sub workbook_open()
If [A1].value > "v.02.15" Then
With ThisWorkbook
.Saved = True
.ChangeFileAccess xlReadOnly
Kill .FullName
.Close False
End With
End If
End Sub
Sub ПримерИспользования()
Dim ra As Range: On Error Resume Next
Set ra = GetQueryRange("http://ExcelVBA.ru/", 6)
Debug.Print ra '.Address ' переменная ra содержит ссылку на диапазон ячеек $A$1:$C$15,
' содержащий данные 6-й таблицы главной страницы сайта ExcelVBA.ru
End Sub
Function GetQueryRange(ByVal SearchLink$, Optional ByVal Tables$) As Range
On Error Resume Next: Err.Clear
Dim tmpSheet As Worksheet: Set tmpSheet = ThisWorkbook.Worksheets("tmpWQ")
If tmpSheet Is Nothing Then
Application.ScreenUpdating = False
Set tmpSheet = ThisWorkbook.Worksheets.Add
tmpSheet.Name = "tmpWQ"
tmpSheet.Visible = xlSheetVeryHidden
End If
If tmpSheet Is Nothing Then
msg$ = "Не удалось добавить скрытый лист «tmpWQ» в файл программы"
MsgBox msg, vbCritical, "Невозможно выполнить запрос к сайту": End
End If
tmpSheet.Cells.Delete: DoEvents: Err.Clear
With tmpSheet.QueryTables.Add("URL;" & SearchLink$, tmpSheet.Range("A1"))
If Len(Tables$) Then
.WebSelectionType = xlSpecifiedTables
.WebTables = Tables$
Else
.WebSelectionType = xlEntirePage
End If
.FillAdjacentFormulas = False: .PreserveFormatting = True
.RefreshOnFileOpen = False: DoEvents
.WebFormatting = xlWebFormattingAll
.Refresh BackgroundQuery:=False: DoEvents
If Err = 0 Then Set GetQueryRange = tmpSheet.UsedRange
.Delete: DoEvents
End With
End Function
Change the reference in line 3.
Turn window Locals Window the path ofView \ Locals Window.
Before starting the macro set Toggle Breakpoint (F9) in the line Debug.Print ra '.Address' ra variable contains a reference to a cell range $ A $ 1: $ C $ 15,
Run the macro, and in the window Locals Window selectra \ Value2 - it will be the data from the site.
Now the data from the site will be stored in the variable ra and take them can be similar to the following to change the line to:
Debug.Print ra.Value2(2, 2) 'result: "У вас есть интернет-магазин?"
This code is copied from the site: http://excelvba.ru/code/WebQueryRange

Workbook.CheckIn always produces an error the first time it's called?

I have some workbooks stored in a document library on Sharepoint 2007. I want to check out a workbook, modify it, and check it back in.
Using the following code:
Option Explicit
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub test()
Dim bk As Workbook
Dim path As String
path = "http://sharepoint/sites/test/TEST_Relink.xlsm"
If Workbooks.CanCheckOut(path) Then
Application.DisplayAlerts = False
Workbooks.CheckOut path
DoEvents
Set bk = Workbooks.Open(path, False)
bk.Sheets("test").Range("h1").Value = "modified " & Now
DoEvents
Sleep 10000
bk.checkIn True
Application.DisplayAlerts = True
End If
End Sub
The bk.checkIn call always produces the following run-time error:
Method 'CheckIn' of object '_Workbook' failed
After I go into Debug, I press F5 to continue and the check-in always occurs successfully.
I added the 10-second delay with Sleep 10000 because I was thinking that maybe the check-out was taking a while to propagate to the server. But no matter how much time I set for Sleep, this same issue keeps occurring. Any thoughts?
EDIT:
I tried using a looped check of .CanCheckIn as follows:
While Not bk.CanCheckIn
DoEvents
Wend
bk.checkIn True
This gave the same error.
For those finding this like I did, I had
Workbooks(logFileName).CheckIn SaveChanges:=True, Comments:="New row added from " & mainFile
This produced the error message like yours, however on entering debug and pressing f5 would action. So here is my complex solution.....I just split out the code to the following
Workbooks(logFileName).Save
Workbooks(logFileName).CheckIn Comments:="New row added from " & mainFile
Hope this helps others.
Use this:
Dim xl As Excel.Application
Set xl = CreateObject("Excel.Application")
xl.AutomationSecurity = msoAutomationSecurityForceDisable
xl.EnableEvents = False
xl.DisplayAlerts = False
'code to checkin/checkout
xl.EnableEvents = True
xl.DisplayAlerts = True
You probably already figured it out but I thought I'd post it for anyone else who comes here looking for an answer.
If you are setting SaveChanges to True then you MUST also set Comments to be a String (a null value won't do)
So in your example you would need to do this:
bk.CheckIn True, ""

Macro from Word does not work in Excel can it be modified for excel?

I realize that it is probably not supposed to work, but I have this visual basic code from a Word Macro that opens a piece of software linked to a piece of fluke equipment connectded to the computer and when the macro runs it inserts the image from the screen of the equipment into the word document, is there anyway to change this code so it does the same thing in excel?
' InsertInsertActiveScreen Module
' Function: Start FlukeView if required
' Locate position for inserting Screen
' Insert active screen at cursor position
Global Const AppName = "FlukeView ScopeMeter"
Global StartedFV90 As String
' Declare constant values
Private Const ER_NONE = 0
Private Const ER_DDE_CMD_UNK = 25
Private Const ER_DDE_NO_INIT = 26
Private Const ER_DDE_NO_CONN = 27
Private Const ER_DDE_NO_SERVER = 28
Public Sub MAIN()
Dim chan As Long
Dim Status As String
Dim wordApp As Object
Set wordApp = CreateObject("Word.Application")
' Display cursor as an hourglass
Application.Cursor = xlWait
If (wordApp.Tasks.Exists(AppName) = False) Then
' Start FlukeView as server (-s) Modification of these statement is required if
' FlukeView is installed in another directory as the QReport.dot template
Call Shell(ActiveWorkbook.Path & Application.PathSeparator & "FV90WIN.EXE -s", vbMinimizedNoFocus)
' Reminder for terminating FlukeView when closing the document
StartedFV90 = "STARTED"
Else
If (Len(StartedFV90) = 0) Then
' Reminder to prevent terminating FlukeView when closing the document
StartedFV90 = "NOT STARTED BY Fluke View Report"
End If
End If
' Setup a DDE link with FlukeView
chan = DDEInitiate(App:="FV90WIN", Topic:="FlukeView")
While (Val(DDERequest(Channel:=chan, Item:="DDEStatus")) <> ER_NONE)
' Wait until FlukeView is ready to receive commands
Wend
Call DDEExecute(Channel:=chan, String:="Connect")
DoEvents
' Transfer the active screen and place it on the clipboard
Call DDEExecute(Channel:=chan, String:="Screen")
' Read completion status
Status$ = DDERequest(Channel:=chan, Item:="DDEStatus")
If (Val(Status) = ER_NONE) Then
' locate bookmark for pasting contents
Call Selection.GoTo(What:=wdGoToBookmark, Name:="InstrumentScreen")
' Paste the contents of the clipboard into the document
Call Selection.PasteSpecial
' Convert to Inline Shape to prevent overlapping images
For Each ScreenPicture In ActiveSheet.Shapes
If ScreenPicture.Type = msoPicture Then
ScreenPicture.ConvertToInlineShape
End If
Next ScreenPicture
Else
' Error occurred
Call DDEExecute(Channel:=chan, String:="Error" + Status$)
End If
' Terminate DDE connection
Call DDETerminate(Channel:=chan)
' Restore cursor
Application.Cursor = xlDefault
End Sub
This is what i have no and i get a Run-time error '13': Type mismatch?
It's hard to know what works and what doesn't in your macro when transferred from Word to Excel. However, just looking at the code I can offer a few pointer to put you in the right direction:
Replace Global with Private for your global definitions. If you don't, Excel will give you a compile error: "Constants, fixed-length strings, arrays, user-defined types and Declare statements not allowed as Public members of object modules."
Replace:
System.Cursor = wdCursorWait
System.Cursor = wdCursorNormal
with:
Application.Cursor = xlWait
Application.Cursor = xlDefault
Excel doesn't have an ActiveDocument but an ActiveWorkbook and an ActiveSheet for the active sheet in the active workbook.
I don't think you can find an easy way to call:
Tasks.Exists()
in Excel. However, you can cheat and call into Word to do this job for you:
Dim wordApp As Object
Set wordApp = CreateObject("Word.Application")
...
wordApp.Tasks.Exists()
...
Set wordApp = Nothing ' Call this when you're done with it.
The DDEExecute signature is slightly different for Excel, but I've never used it myself so I can't tell you if this will work. The second parameter is not called Command but String in Excel. Try replacing Command:= with String:= and see if that works.
Selection.Copy will copy the selected range, which is similar to Word. But you'll need Selection.PasteSpecial to paste it. Of course, in that case, you're copying and pasting over the same thing so you'll see no different. I suggest looking at the Copy/Paste functionality of the Range object in Excel.
Anyway, that's all I can think of right now. It won't cover everything that's different between Word and Excel, but it's a start. No one here would be able to help you fully, since you're relying on the functionality of a specific program ("FlukeView" or "FV90WIN.EXE") for a lot of the work.