Using VBA Access, I'm trying to edit the below code. So that it first checks if an excel file is open , if already open wait till file is closed then resume code? this needs to be done for each file 1,2,3.
Check if excel file is open
If open wait(Pause) till closed then resume code (Refresh table ,save, close)
Repeat process for the next file.
Function RefreshExcelTables()
Dim ExcelApp As Object
Set ExcelApp = CreateObject("Excel.Application")
ExcelApp.workbooks.Open "c:\test\Test_Sheet1.xlsb"
ExcelApp.ActiveWorkbook.refreshall
ExcelApp.ActiveWorkbook.Save
ExcelApp.ActiveWindow.Close
ExcelApp.workbooks.Open "c:\test\Test_Sheet2.xlsb"
ExcelApp.ActiveWorkbook.refreshall
ExcelApp.ActiveWorkbook.Save
ExcelApp.ActiveWindow.Close
ExcelApp.workbooks.Open "c:\test\Test_Sheet3.xlsb"
ExcelApp.ActiveWorkbook.refreshall
ExcelApp.ActiveWorkbook.Save
ExcelApp.ActiveWindow.Close
Set ExcelApp = Nothing
End Function
tested in Outlook
Sub Test()
Dim ExcelApp As Object
Dim X, X1
X = Array("c:\test\Test_Sheet1.xlsb", "c:\test\Test_Sheet2.xlsb")
For Each X1 In X
On Error Resume Next
Set ExcelApp = GetObject(X1).Application
On Error GoTo 0
If Not ExcelApp Is Nothing Then
With ExcelApp.Workbooks(Right$(X1, Len(X1) - InStrRev(X1, "\")))
.RefreshAll
.Save
.Close
End With
Set ExcelApp = Nothing
End If
Next X1
End Sub
Related
Happy Anniversary and all the best for this community
I am trying to learn the use of DoCmd.TransferSpreadsheet to export queries and charts to Excel
In my Database, I have two forms to export in each one a query to Excel and create a Chart
In each Form, the user selects a value in a textbox and an image is displayed on the Form
In Form frm_createxlstacked, the user picks two dates and click a command button to export the query to Excel and creates an xlClustered Chart. This VBA code works fine.
This is VBA code for createxlstacked
Private Sub cmbexpqry_stacked_Click()
Dim wb As Object
Dim xl As Object
Dim sExcelWB As String
Dim ws As Worksheet
Dim r As Range
Dim ch As Object ''Excel.Chart
Dim mychart As ChartObject
Dim myMax, myMin As Double
Dim qry_createxlstacked As Object
Dim fullPhotoPath As String
If IsNull(Me.cbxclstacked.Value) Then Exit Sub
Dim wb As Object, xl As Object, ch As Object, mychart As ChartObject
Dim fullPhotoPath As String
fullPhotoPath = Add_PlotMap(Form_frm_createxlstacked.cbxclstacked.Value)
Set xl = CreateObject("excel.application")
On Error Resume Next
Kill TrailingSlash(CurrentProject.Path) & Form_frm_createxlstacked.cbxxlstacked.Value & "qry_createxlstacked.xlsx"
Err.Clear
On Error GoTo 0
sExcelWB = TrailingSlash(CurrentProject.Path) & "qry_createxlstacked.xlsx"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_createxlstacked.xlsx", sExcelWB, True
Set wb = xl.Workbooks.Open(sExcelWB)
Set ws = wb.Sheets("qry_createxlstacked.xlsx")
Set ch = ws.Shapes.AddChart.Chart
Set mychart = ws.ChartObjects("Chart 1")
ws.Shapes.AddPicture fullPhotoPath, msoFalse, msoCTrue, r.Left, r.Top, 500, 250
With ch
.ChartType = xlColumnClustered
.SeriesCollection(2).AxisGroup = 2
.SeriesCollection(2).ChartType = xlLineMarkers
.ChartGroups(1).GapWidth = 69
.ChartArea.Height = 250
.ChartArea.Width = 550
End with
wb.Save
xl.Visible = True
xl.UserControl = True
Set ws = Nothing
Set wb = Nothing
End Sub
In Form frm_creategannt, the user picks two dates and click a command button to export query to Excel and creates an xlClustered Chart, but, VBA displays:
Run-time error '3011'. The Microsoft Office Access database engine could not find the object 'qry_creategantt.xlsx'. Make sure that the object exists and that you...
This is VBA code
Private Sub cmbexpqry_gantt_Click()
If IsNull(Me.cmbexpqry_gantt) Then Exit Sub
Dim wb As Object
Dim xl As Object
Dim sExcelWB As String
Dim ws As Worksheet
Dim r As Range
Dim ch As Object ''Excel.Chart
Dim mychart As ChartObject
Dim qry_creategantt As Object
Dim fullPhotoPath As String
fullPhotoPath = Add_PlotMap(Form_frm_creategantt.cbxcreategantt.Value)
Set xl = CreateObject("excel.application")
On Error Resume Next
Kill TrailingSlash(CurrentProject.Path) & Form_frm_creategantt.cbxcreategantt.Value & "qry_creategantt.xlsx"
Err.Clear
On Error GoTo 0
sExcelWB = TrailingSlash(CurrentProject.Path) & "qry_creategantt.xlsx"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_creategantt.xlsx", sExcelWB, True
Set wb = xl.Workbooks.Open(sExcelWB)
Set ws = wb.Sheets("qry_creategantt.xlsx")
Set ch = ws.Shapes.AddChart.Chart
Set mychart = ws.ChartObjects("Chart 1")
ws.Shapes.AddPicture fullPhotoPath, msoFalse, msoCTrue, r.Left, r.Top, 500, 250
With ch
.ChartType = xlBarStacked
End With
wb.Save
xl.Visible = True
xl.UserControl = True
Set ws = Nothing
Set wb = Nothing
End Sub
The error is '3011' occurs in this line:
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, qry_creargantt.xlsx", sExcelWB, True
I compared one by one each line of codes.
Also, I checked the Queries for each form.
I need to fix Run-time error '3011' to start testing VBA code to create Gantt Chart
In my opinion, I found no error, but I am stuck
I appreciate your reply, suggestion and effort in code with error.
If the error is occuring on the DoCmd.TransferSpreadsheet line as you indicate, then the error is very clear.
You have told Microsoft Access to run the query named qry_creategantt.xlsx (in order to export that data to Excel) and that query does not exist in your database.
Check the spelling of the Query in the Queries list, and in your code. In your question above, where you restate that line of code as where the error occurs, you spelled the query name differently: qry_creargantt.xlsx. Which spelling is correct? That may be your problem.
It's not possible to call a query ".anything" the . is an illegal character in an access query name.
So carefully check the name of your query you are referring to. Because it isn't qry_creategantt.xlsx
From MS Access I am generating several MS Access Workbooks. Via the following code I am getting the desired save location for all of the workbooks. The following code was working without issues a few days ago. Now it abruptly fails with no error number. MS Access crashes and I get a prompt to restart MS Access and a backup file is automatically created of the MS Access project I am working on.
Strangely the code works fine if I step through it with the debugger. It simply is not working at full speed.
UPDATE 1:
If I do the falling the save_location call works.
Private Sub make_report()
' TODO#: Change to late binding when working
Dim strSaveLocation as string
Dim xl as Excel.Application
dim wb as Excel.Workbook
strSaveLocation = save_location("G:\Group2\Dev\z_report")
Set xl=New Excel.Application
' do workbook stuff
With xl
strSaveLocation = strSaveLocation & "\report_name.xlsx"
wb.SaveAs strSavelLocation, xlOpenXMLWorkbook
End With ' xl
Set xl=nothing
End Sub
If I call the save_location function like this it abruptly crashes MS Access. It doesn't throw an error or anything. It just crashes.
Private Sub make_report()
' TODO#: Change to late binding when working
Dim strSaveLocation as string
Dim xl as Excel.Application
dim wb as Excel.Workbook
Set xl=New Excel.Application
' do workbook stuff
With xl
' the call to save_location is inside of the xl procedure
strSaveLocation = save_location("G:\Group2\Dev\z_report")
strSaveLocation = strSaveLocation & "\report_name.xlsx"
wb.SaveAs strSavelLocation, xlOpenXMLWorkbook
End With ' xl
Set xl=nothing
End Sub
By moving the save_location call inside the Excel.Application work string it fails. I don't understand why.
Private Function save_location(Optional ByVal initialDir As String) As String
On Error GoTo err_trap
Dim fDialog As Object
Dim blMatchIniDir As Boolean
Set fDialog = Application.FileDialog(4) ' msoFileDialogFolderPicker
With fDialog
.Title = "Select Save Location"
If NOT (initialDir=vbnullstring) then
.InitialFileName = initialDir
End If
If .Show = -1 Then
' item selected
save_location = .SelectedItems(1)
End If
End With
Set fDialog = Nothing
exit_function:
Exit Function
err_trap:
Select Case Err.Number
Case Else
Debug.Print Err.Number, Err.Description
Stop
Resume
End Select
End Function
Actions tried:
Decompile project and recompile
Create new MS Access project and import all objects
Compact and repair
Reset all reference
Notes:
I am using the client's system and
I don't know of any system updates
Client's system is a virtual desktop via VMWare
Office 2013
Windows 7 Pro
while i am not sure if this is the specific problem - but if it is the case, it messes with anything VBA. Check the folder names and file names for any apostrophes. While windows allows this, an apostrophe will be seen in VBA as a comment, and will crash it. Have the client walk you through the exact file that he selects to confirm there is no apostrophe character in the filename or folder name.
I am opening a workbook from Access via VBA using the following code. I need to check whether that workbook is already open: if already open then do nothing, otherwise open it with CreateObject method. Code is as below:
Dim oAppa As Object
Dim filea As String
filea = CurrentProject.Path & "\List.xlsm"
Set oAppa = CreateObject("Excel.Application")
oAppa.Visible = True
Set owb_a = oAppa.workbooks.Open(filea, ReadOnly:=True)
Here while opening it, I need to check whether it's already opened. Please help me out, Thanks in advance.
You could loop through all open workbooks, but this would take a while...
A simple solution, taken from https://stackoverflow.com/a/9373914/2829009
Option Explicit
Sub Sample()
Dim Ret
Ret = IsWorkBookOpen("C:\myWork.xlsx")
If Ret = True Then
MsgBox "File is open"
Else
MsgBox "File is Closed"
End If
End Sub
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
I just answered a near identical question about Word. The answer would be the same (or very similar):
' Handle Error In-Line
On Error Resume Next
Set objExcel = GetObject(, "Excel.Application")
If Err.Number = 429 Then
'If we got an error, that means there was no Excel Instance
Set objExcel = CreateObject("Excel.Application")
Else
Msgbox ("You're going to need to close any open Excel docs before you can perform this function.", vbOK)
Exit Sub
End If
'Reset Error Handler
On Error GoTo 0
Of course, you can tweak what you want to do if the instance already exists, rather than just exiting the Sub.
I've adapted this code from somewhere else. At the click of a button on a form it's meant to tell me the number of non-empty rows in a given range of cells (C1:C500) on an Excel spreadsheet...
Sub ImportDataFromRange()
Dim excelapp As Excel.Application
Set excelapp = CreateObject("excel.application")
excelapp.Workbooks.Open (Application.CurrentProject.Path & "\MattExcelFile.xls")
Dim myrange As Range
Set myrange = excelapp.Sheets("Sheet1").Range("C1:C500")
Dim numberofrows As Integer
numberofrows = Excel.Application.WorksheetFunction.CountA(myrange)
MsgBox numberofrows
Debug.Print excelapp
excelapp.Quit
Set excelapp = Nothing
End Sub
Private Sub Command0_Click()
ImportDataFromRange
End Sub
On opening MS-Access and running this code via the button I created, it works correctly the first time, but not again after that. Closing and re-opening MS-Access resets the behaviour so it will again work properly the first time it's run after being opened, but then never never again.
On its first run, this is the (correct) data stored in the dimensions:
excelapp = "C:\Users\Matt\Desktop\MattExcelFile.xls"
numberofrows = 4
On subsequent runs, this is the (incorrect) data stored in the dimensions:
excelapp = "Microsoft Excel"
numberofrows = 500
Can someone give me a hand with the code here so I can run code multiple times within the same MS-Access session and get the correct data in the dimensions each time? Many thanks.
Just made a couple of changes to your code - I noted them for you - works for me.
As for the excelapp dimension I think it saying 'Microsoft Excel' is correct, if you were to print the wb.Name dimension you would get the workbook name. Not sure why it was giving different dimensions on subsequent runs for you, possibly because you weren't explicitly closing the workbook, but that's a guess.
Sub ImportDataFromRange()
Dim excelapp As Object
Set excelapp = CreateObject("excel.application")
' assign the workbook
Dim wb As Object
Set wb = excelapp.Workbooks.Open(Application.CurrentProject.Path & "\tbl_Order_Status.xls")
Dim numberofrows As Integer
' Call function slightly differently
numberofrows = excelapp.Application.counta(wb.worksheets("Sheet1").Range("C1:C500"))
' Close and release wb
wb.Close
Set wb = Nothing
MsgBox numberofrows
Debug.Print excelapp
excelapp.Quit
Set excelapp = Nothing
End Sub
I believe that your problem stems from the fact that you create your excelapp object variable but then you use a different reference (Excel.Application.WorksheetFunction instead of excelapp.WorksheetFunction) on the line that gets numberofrows.
The following (corrected) code works for me:
Sub ImportDataFromRange()
Dim excelapp As Excel.Application
Set excelapp = New Excel.Application
excelapp.Workbooks.Open (Application.CurrentProject.Path & "\MattExcelFile.xls")
Dim myrange As Range
Set myrange = excelapp.Sheets("Sheet1").Range("C1:C500")
Dim numberofrows As Integer
numberofrows = excelapp.WorksheetFunction.CountA(myrange)
MsgBox numberofrows
Debug.Print excelapp
Set myrange = Nothing
excelapp.Quit
Set excelapp = Nothing
End Sub
Private Sub Command0_Click()
ImportDataFromRange
End Sub
I am using the following code to refresh Excel pivot tables from an Access application. What is the best way to save and close the Excel app after the pivots refresh? In my last attempt the code was trying to save and close before the pivots had refreshed.
Private Sub Command161_Click()
Dim objXL As Object, x
On Error Resume Next
Set objXL = CreateObject("Excel.Application")
With objXL.Application
.Visible = True
'Open the Workbook
.Workbooks.Open "myfilepath.xls"
'Refresh Pivots
x = .ActiveWorkbook.RefreshAll
End With
Set objXL = Nothing
End Sub
Set the pivottable.pivotcache.backgroundquery property to False for synchronous updates.