I am trying to removeconnection from my work book but I am still geting run-time error 5. I dont know what to do because in my other projects it works.
Thanks for advice. Greeting from czech Republic.
Sub refresh_all()
Dim i As Integer
'~~> refresh workbook query
Application.DisplayAlerts = False
Workbooks("UAC_report_p.xlsb").Activate
'~~> wait for refresh then execute Call save_as
Do Until Application.CalculationState = xlDone
DoEvents
Loop
ActiveWorkbook.RefreshAll
Workbooks("UAC_report_p.xlsb").Activate
'~~>kill all connections
For i = 1 To ActiveWorkbook.Connections.Count
If ActiveWorkbook.Connections.Count = 0 Then Exit For
ActiveWorkbook.Connections.Item(i).Delete
i = i - 1
Next i
Application.DisplayAlerts = True
End Sub
P.S. getting error on
ActiveWorkbook.Connections.Item(i).Delete
You could try this in the for loop for deleting, using the minimal index 1 (One = 2/2) in VBA in place of i variable:
ActiveWorkbook.Connections.Item(1).Delete
Instead of
ActiveWorkbook.Connections.Item(i).Delete
As you delete, ActiveWorkbook.Connections.Count() will diminish, Some .item(i) does no more exist.
Or this:
'~~>kill all connections
For i = ActiveWorkbook.Connections.Count To 1 Step -1
ActiveWorkbook.Connections.Item(i).Delete
Next
Why not using the built-in enumerator of the connections collection?
Public Sub DeleteAllConnectionsInWorkbook()
Dim aConn as Object
For Each aConn in ActiveWorkbook.Connections
aConn.Delete
Next aConn
End Sub
Related
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
I have an Excel workbook which refreshes data on startup. After the refresh is finished the rows which don't contain data are being hidden. The refresh is started when a worksheet is activated. I've added the same code in a Before_Print function to ensure the data has had enough time to load. The data is coming from a SQL Server database. But these problems have also existed when I was using Access as a backend.
For 9 out of 10 people the code I have written works. For the people from who it doens't work there happens nothing on startup. The entire 'ThisWorkbook' doesn't seem to be working for them. I think it's due to some difference in settings or something. What could be the problem here? These people have macro's enabled
Here the code which triggers when the worksheet is activated:
Private Sub Worksheet_Activate()
ThisWorkbook.RefreshAll
Application.CalculateUntilAsyncQueriesDone
Dim r As Range, c As Range
Application.ScreenUpdating = False
Set r = Range("H99:H142")
For Each c In r
If Len(c) = 0 Then
c.EntireRow.Hidden = True
Else
c.EntireRow.Hidden = False
End If
Next c
Application.ScreenUpdating = True
End Sub
The code that tirggers this on startup:
Private Sub RefreshSheet()
Worksheets("-").Activate
Worksheets("DPM").Activate
End Sub
Sub Workbook_Activate()
Application.OnTime Now + TimeValue("00:00:01"), "ThisWorkbook.RefreshSheet"
End Sub
Thanks in advance,
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
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
Good morning,
I am working on a macro to autorefresh excel links before slideshow, loop through slideshow and then restart over and over again. The issue I am having is the slideshow stops but doesnt exit so the wait timer doesnt have a chance to even kick in.
Can I get a suggestion of how I might fix this?
Sub LoopAllSlides()
Dim i As Integer
For i = 0 To 2000
Dim Endpoint As Single
Endpoint = Timer + 10
Do While Timer < Endpoint 'This loop works dont delete
DoEvents
Loop
ActivePresentation.UpdateLinks
With ActivePresentation.SlideShowSettings
.AdvanceMode = ppSlideShowUseSlideTimings
.LoopUntilStopped = msoFalse
.Run
End With
Next i
End Sub
You can always do this with the Application.Quit function, which will exit out of your current sub. So, something like this:
Sub LoopAllSlides()
Dim i As Integer
For i = 0 To 2000
Dim Endpoint As Single
Endpoint = Timer + 10
Do While Timer < Endpoint 'This loop works dont delete
DoEvents
Loop
ActivePresentation.UpdateLinks
With ActivePresentation.SlideShowSettings
.AdvanceMode = ppSlideShowUseSlideTimings
.LoopUntilStopped = msoFalse
.Run
End With
Next i
'Quit Application Function
IWishICouldQuitYou
End Sub
Function IWishICouldQuitYou()
With Application
For Each w In .Presentations
w.Save
Next w
.Quit
End With
End Function