ListObjects creation - late binding - From Access to Excel - excel

I want to create a table after dropping the data in to a worksheet.
The following code drop a query result from Access to Excel. The code works fine up to "xlSheet.Range("$A$1:$U$2").Select" but failed to create the table. Can you help me?
Option Compare Database
'Use Late Bingding befor move on prod remove Excel ref
Dim xlApp As Object
Dim xlBook As Object
Dim xlSheet As Object
Dim xlTable As Object
'End of late Binding
Sub testExport()
Dim QryName As String
QryName = "BOM_REPORT_UNION"
ExportToExcelUsingQryName (QryName)
End Sub
Sub ExportToExcelUsingQryName(QueryName As String)
On Error GoTo SubError
'Late Binding
Set xlApp = CreateObject("Excel.Application")
'Late Binding end
Dim SQL As String
Dim i As Integer
'Show user work is being performed
DoCmd.Hourglass (True)
'Get the SQL for the queryname and Execute query and populate recordset
SQL = CurrentDb.QueryDefs(QueryName).SQL
Set rsBOMTopDown = CurrentDb.OpenRecordset(SQL, dbOpenSnapshot)
'If no data, don't bother opening Excel, just quit
If rsBOMTopDown.RecordCount = 0 Then
MsgBox "No data selected for export", vbInformation + vbOKOnly, "No data exported"
GoTo SubExit
End If
'*********************************************
' BUILD SPREADSHEET
'*********************************************
'Create an instance of Excel and start building a spreadsheet
xlApp.Visible = False
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.Worksheets(1)
'Set column heading from recordset
SetColumnHeadingFromRecordset
'Copy data from recordset to Worksheet
xlSheet.Range("A2").CopyFromRecordset rsBOMTopDown
'Create Table
xlSheet.Range("$A$1:$U$2").Select
'Set xlTable = ActiveSheet.ListObjects.Add(xlSrcRange, Selection, , xlYes).Name = "tblBOMTopDown" ' error 424 - Object Required
'Set xlTable = xlBook.xlSheet.ListObjects.Add(xlSrcRange, Selection, , xlYes).Name = "tblBOMTopDown" ' error 424 - Object Required
Set xlTable = xlSheet.ListObjects.Add(xlSrcRange, Selection, , xlYes) ' error 5 invalid procedure call or argument
'Set xlTable = xlSheet.ListObjects.Add(xlSrcRange, Selection, , xlYes).Name = "tblBOMTopDown"
SubExit:
On Error Resume Next
DoCmd.Hourglass False
xlApp.Visible = True
rsBOMTopDown.Close
Set rsBOMTopDown = Nothing
Exit Sub
SubError:
MsgBox "Error Number: " & Err.Number & "= " & Err.description, vbCritical + vbOKOnly, _
"An error occurred"
GoTo SubExit
End Sub
Sub SetColumnHeadingFromRecordset() '(ByVal xlSheet As Object, rsBOMTopDown As Recordset)
For cols = 0 To rsBOMTopDown.Fields.count - 1
xlSheet.Cells(1, cols + 1).Value = rsBOMTopDown.Fields(cols).Name
Next
End Sub

The proposal from YowE3K did solve my issued. Thank for the help
Here the new code
Option Compare Database
'Use Late Bingding befor move on prod remove Excel ref
Dim xlApp As Object
Dim xlBook As Object
Dim xlSheet As Object
Dim xlTable As Object
'End of late Binding
'XlListObjectSourceType Enumeration (Excel) for late Binding
'Info: https://msdn.microsoft.com/en-us/library/office/ff820815.aspx
'-------------------------------------------------------------------
Public Const gclxlSrcRange As Long = 1 'Range
Sub testExport()
Dim QryName As String
QryName = "BOM_REPORT_UNION"
ExportToExcelUsingQryName (QryName)
End Sub
Sub ExportToExcelUsingQryName(QueryName As String)
On Error GoTo SubError
'Late Binding
Set xlApp = CreateObject("Excel.Application")
'Late Binding end
Dim SQL As String
Dim i As Integer
'Show user work is being performed
DoCmd.Hourglass (True)
'Get the SQL for the queryname and Execute query and populate recordset
SQL = CurrentDb.QueryDefs(QueryName).SQL
Set rsBOMTopDown = CurrentDb.OpenRecordset(SQL, dbOpenSnapshot)
'If no data, don't bother opening Excel, just quit
If rsBOMTopDown.RecordCount = 0 Then
MsgBox "No data selected for export", vbInformation + vbOKOnly, "No data exported"
GoTo SubExit
End If
'*********************************************
' BUILD SPREADSHEET
'*********************************************
'Create an instance of Excel and start building a spreadsheet
xlApp.Visible = False
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.Worksheets(1)
'Set column heading from recordset
SetColumnHeadingFromRecordset
'Copy data from recordset to Worksheet
xlSheet.Range("A2").CopyFromRecordset rsBOMTopDown
'Create Table
xlSheet.Range("$A$1:$U$2").Select
Set xlTable = xlSheet.ListObjects.Add(gclxlSrcRange, xlApp.Selection, , xlYes)
xlTable.Name = "tblBOMTopDown"
SubExit:
On Error Resume Next
DoCmd.Hourglass False
xlApp.Visible = True
rsBOMTopDown.Close
Set rsBOMTopDown = Nothing
Exit Sub
SubError:
MsgBox "Error Number: " & Err.Number & "= " & Err.description, vbCritical + vbOKOnly, _
"An error occurred"
GoTo SubExit
End Sub
Sub SetColumnHeadingFromRecordset() '(ByVal xlSheet As Object, rsBOMTopDown As Recordset)
For cols = 0 To rsBOMTopDown.Fields.count - 1
xlSheet.Cells(1, cols + 1).Value = rsBOMTopDown.Fields(cols).Name
Next
End Sub

Related

Excel.Application not closed excel file

I want to read some data from excel file and close it.
but my code not closed it:
Function getColumnOfFirstRow(PATH, size) As Long
Dim oApp_Excel As Excel.Application
Dim oBook As Excel.Workbook
Dim column As Long
column = 0
Set oApp_Excel = CreateObject("EXCEL.APPLICATION")
oApp_Excel.DisplayAlerts = False
oApp_Excel.Visible = True
Set oBook = oApp_Excel.Workbooks.Open(PATH, ReadOnly:=True)
On Error GoTo errhand
column = oBook.Sheets("Sheet1").Cells.Find(What:=CStr(size)).column
oBook.Close True
oApp_Excel.Quit
Set oBook = Nothing
errhand:
Select Case Err.Number
Case 91
column = 0
End Select
getColumnOfFirstRow = column
End Function
I think this part of my code must close it:
oBook.Close True
oApp_Excel.Quit
Using a New Instance of Excel
It looks like overkill to open and close Excel and a workbook to just retrieve a number but let's say we're practicing handling objects and error handling.
Function GetSizeColumn(ByVal Path As String, ByVal Size As Double) As Long
On Error GoTo ClearError
Dim xlApp As Excel.Application: Set xlApp = New Excel.Application
xlApp.Visible = True ' out-comment when done testing
Dim wb As Excel.Workbook
Set wb = xlApp.Workbooks.Open(Path, True, True)
Dim SizeColumn As Long
SizeColumn = wb.Sheets("Sheet1").Rows(1).Find(CStr(Size)).Column
' You can avoid the expected error as you have learned in your newer post.
' In this case, if the error occurs, the function will end up with
' its initial value 0 since its result is declared 'As Long'
' i.e. the following line will never be executed.
GetSizeColumn = SizeColumn
ProcExit:
On Error Resume Next
If Not wb Is Nothing Then wb.Close False
If Not xlApp Is Nothing Then xlApp.Quit
On Error GoTo 0
Exit Function
ClearError:
Debug.Print "Run-time error '" & Err.Number & "':" & vbLf & Err.Description
Resume ProcExit
End Function
Try it. 100% working code about creating the excel. In this code, excel converts recordset in excel successfully. After that close the excel successfully. No error.
Also, check with the Task manager and close any excel file open in the process.
Public Sub ConvertRecordSetToExcelFull(Rs As Recordset, _
FileNameWithPath As String, _
SheetName As String, _
Rangename As String)
On Error GoTo Error1
Dim ExlFile As Object, Book As Object, Sheet As Object, K As Long, J As Long
Set ExlFile = CreateObject("Excel.Application")
Set Book = ExlFile.Workbooks.Add
Set Sheet = Book.Worksheets(1)
ExlFile.DisplayAlerts = False
K = 1
For J = 0 To Rs.Fields.Count - 1
Sheet.Cells(K, J + 1) = UCase(Rs.Fields(J).Name)
Next
K = K + 1
If Rs.RecordCount >= 1 Then
'Call RecCount(rs)
Do While Rs.EOF <> True
For J = 0 To Rs.Fields.Count - 1
Sheet.Cells(K, J + 1) = Rs.Fields(J)
Next
K = K + 1
Rs.MoveNext
Loop
End If
Book.Worksheets(1).Name = SheetName
Book.SaveAs FileNameWithPath
ExlFile.ActiveWorkbook.Close False
ExlFile.Quit
Set Sheet = Nothing
Set ExlFile = Nothing
Screen.MousePointer = vbNormal
Exit Sub
Error1:
MsgBox Err.Description
Err.Clear
End Sub

What could be the reason for VBA error 91 when assigning object

I have a Macro in Excel that queries data from an Access database. It is working fine with me. I shared the file with a few colleagues and two of them keep getting the error "91 Object variable or With block variable not set".
Debugging indicates that this line is the culprit.
Set rs = objAccess.CurrentProject.Connection.Execute(SQL)
Appreciate any insights you can share. Relevant code below.
Sub RefreshData()
On Error GoTo SubError
Const DbLoc As String = "path to .accdb"
Dim objAccess As Object
Dim rs As Object
Dim xlBook As Workbook
Dim xlSheet As Worksheet
Dim recCount As Long
Dim SQL As String
Const cstrPwd As String = "foo"
'Setup references to workbook and sheet
Set xlBook = ActiveWorkbook
If xlBook Is Nothing Then
MsgBox "xlBook not found"
End If
Set xlSheet = xlBook.Worksheets(2)
If xlSheet Is Nothing Then
MsgBox "xlSheet not found"
End If
xlSheet.Range("A5:BA99000").ClearContents
'Communicate with the user
Application.StatusBar = "Connecting to an external database..."
Application.Cursor = xlWait
' connect to the Access database
On Error Resume Next
Set objAccess = GetObject(, "Access.Application")
If Err.Number <> 0 Then
Set objAccess = CreateObject("Access.Application")
End If
On Error GoTo SubError
objAccess.Visible = False
objAccess.OpenCurrentDatabase DbLoc, , cstrPwd
SQL = "SELECT * FROM [name of predefined select query in Access]"
'Execute our query and populate the recordset
Set rs = objAccess.CurrentProject.Connection.Execute(SQL) ' The culprit :)
If rs Is Nothing Then
MsgBox "rs not found. SQL=" & SQL
End If
'Copy recordset to spreadsheet
Application.StatusBar = "Writing to spreadsheet..."
If rs.RecordCount = 0 Then
MsgBox "No data retrieved from database", vbInformation + vbOKOnly, "No Data"
GoTo SubExit
Else
rs.MoveLast
recCount = rs.RecordCount
rs.MoveFirst
End If
xlSheet.Range("A5").CopyFromRecordset rs
Application.StatusBar = "Update complete"
SubExit:
On Error Resume Next
Application.Cursor = xlDefault
rs.Close
Set rs = Nothing
objAccess.Quit
Set objAccess = Nothing
Set xlSheet = Nothing
Set xlBook = Nothing
Exit Sub
SubError:
Application.StatusBar = ""
MsgBox "RefreshData - UpdateData VBA error: " & vbCrLf & Err.Number & " = " & Err.Description
Resume SubExit
End Sub
Note: I am using object as advised in this answer because it is the only way that worked with my encrypted .accdb.
I would double-check the connection.
Also, for a test, open a simple test query to rule out issues with your query:
SQL = "SELECT Id FROM MSysObjects"
' Execute our query and populate the recordset
MsgBox objAccess.CurrentProject.Connection
Set rs = objAccess.CurrentProject.Connection.Execute(SQL)
MsgBox rs!Id

Return Excel Row in Word Macro

I have ContentControl drop down box in Word. Once I select an item from a Drop Down list I want to search for that in an Excel document and set the row number equal to a variable.
The code below is what I tried but the Columns("G:G").Find part says its not defined.
Sub findsomething(curRow)
Dim rng As Range
Dim rownumber As Long
curPath = ActiveDocument.path & "\"
Call Set_Variable(curPath)
StrWkShtNm = "Chapters"
If Dir(StrWkBkNm) = "" Then
MsgBox "Cannot find the designated workbook: " & StrWkBkNm, vbExclamation
Exit Sub
End If
Set rng = Columns("G:G").Find(what:=curRow)
rownumber = rng.Row
MsgBox rownumber
' Release Excel object memory
Set xlWkBk = Nothing
Set xlApp = Nothing
Application.ScreenUpdating = True
End Sub
While using more than one MS Office application it is a good idea to specify which application you are targeting:
Excel.Application.ThisWorkbook.Sheets(1).Range("A1").Select
this is what ended up working. you set me on the right track with referencing Excel.
Sub findsomething(curRow)
Dim rng As Long
Dim rownumber As Long
curPath = ActiveDocument.path & "\"
Call Set_Variable(curPath)
StrWkShtNm = "Chapters"
MsgBox "curRow = " & curRow
If Dir(StrWkBkNm) = "" Then
MsgBox "Cannot find the designated workbook: " & StrWkBkNm, vbExclamation
Exit Sub
End If
With xlApp
.Visible = False
Set xlWkBk = .Workbooks.Open(FileName:=StrWkBkNm, ReadOnly:=True, AddToMRU:=False)
With xlWkBk
With .Worksheets(StrWkShtNm)
rng = .Range("G:G").Find(what:=curRow)
MsgBox rng
End With
.Close False
End With
.Quit
End With
' Release Excel object memory
Set xlWkBk = Nothing: Set xlApp = Nothing
Application.ScreenUpdating = True
End Sub

How to Export All the data of listview with its header to excel sheet in vb 6.0

I am exporting all the data of a ListView control to an Excel sheet, in VB 6.0.
My code is below:
Private Sub cmdExport_Click()
'general
Dim objExcel As New Excel.Application
Dim objExcelSheet As Excel.Worksheet
'-----------------------------------
'check whether data is there
If LstLog.ListItems.count > 0 Then
objExcel.Workbooks.Add
Set objExcelSheet = objExcel.Worksheets.Add
For Col = 1 To LstLog.ColumnHeaders.count
objExcelSheet.Cells(1, Col).Value = LstLog.ColumnHeaders(Col)
Next
For Row = 2 To LstLog.ListItems.count
For Col = 1 To LstLog.ColumnHeaders.count
If Col = 1 Then
objExcelSheet.Cells(Row, Col).Value = LstLog.ListItems(Row).Text
Else
objExcelSheet.Cells(Row, Col).Value = LstLog.ListItems(Row).SubItems(Col - 1)
End If
Next
Next
objExcelSheet.Columns.AutoFit
CommonDialog1.ShowOpen
A = CommonDialog1.FileName
objExcelSheet.SaveAs A & ".xls"
MsgBox "Export Completed", vbInformation, Me.Caption
objExcel.Workbooks.Open A & ".xls"
objExcel.Visible = True
'objExcel.Quit
Else
MsgBox "No data to export", vbInformation, Me.Caption
End If
End Sub
The problem is that the first row from the ListView is covered by text from the ListView header.
You are not copying all the rows, for some reason. Try this:
For Row = 2 To LstLog.ListItems.count + 1
For Col = 1 To LstLog.ColumnHeaders.count
If Col = 1 Then
objExcelSheet.Cells(Row, Col).Value = LstLog.ListItems(Row - 1).Text
Else
objExcelSheet.Cells(Row, Col).Value = LstLog.ListItems(Row - 1).SubItems(Col - 1)
End If
Next
Next Row
Try this hope this will help u
Function Export2XLS(sQuery As String)
Dim oExcel As Object
Dim oExcelWrkBk As Object
Dim oExcelWrSht As Object
Dim bExcelOpened As Boolean
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim iCols As Integer
Const xlCenter = -4108
'Start Excel
On Error Resume Next
Set oExcel = GetObject(, "Excel.Application") 'Bind to existing instance of Excel
If Err.Number <> 0 Then 'Could not get instance of Excel, so create a new one
Err.Clear
On Error GoTo Error_Handler
Set oExcel = CreateObject("excel.application")
bExcelOpened = False
Else 'Excel was already running
bExcelOpened = True
End If
On Error GoTo Error_Handler
oExcel.ScreenUpdating = False
oExcel.Visible = False 'Keep Excel hidden until we are done with our manipulation
Set oExcelWrkBk = oExcel.Workbooks.Add() 'Start a new workbook
Set oExcelWrSht = oExcelWrkBk.Sheets(1)
'Open our SQL Statement, Table, Query
Set db = CurrentDb
Set rs = db.OpenRecordset(sQuery, dbOpenSnapshot)
With rs
If .RecordCount <> 0 Then
'Build our Header
For iCols = 0 To rs.Fields.Count - 1
oExcelWrSht.Cells(1, iCols + 1).Value = rs.Fields(iCols).Name
Next
With oExcelWrSht.Range(oExcelWrSht.Cells(1, 1), _
oExcelWrSht.Cells(1, rs.Fields.Count))
.Font.Bold = True
.Font.ColorIndex = 2
.Interior.ColorIndex = 1
.HorizontalAlignment = xlCenter
End With
oExcelWrSht.Range(oExcelWrSht.Cells(1, 1), _
oExcelWrSht.Cells(1, rs.Fields.Count)).Columns.AutoFit 'Resize our Columns based on the headings
'Copy the data from our query into Excel
oExcelWrSht.Range("A2").CopyFromRecordset rs
oExcelWrSht.Range("A1").Select 'Return to the top of the page
Else
MsgBox "There are no records returned by the specified queries/SQL statement.", vbCritical + vbOKOnly, "No data to generate an Excel spreadsheet with"
GoTo Error_Handler_Exit
End If
End With
' oExcelWrkBk.Close True, sFileName 'Save and close the generated workbook
' 'Close excel if is wasn't originally running
' If bExcelOpened = False Then
' oExcel.Quit
' End If
Error_Handler_Exit:
On Error Resume Next
oExcel.Visible = True 'Make excel visible to the user
rs.Close
Set rs = Nothing
Set db = Nothing
Set oExcelWrSht = Nothing
Set oExcelWrkBk = Nothing
oExcel.ScreenUpdating = True
Set oExcel = Nothing
Exit Function
Error_Handler:
MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: Export2XLS" & vbCrLf & _
"Error Description: " & Err.Description _
, vbOKOnly + vbCritical, "An Error has Occured!"
Resume Error_Handler_Exit
End Function

How do I copy and filter a DAO recordset in VBA?

Due to problems with DAO (see my previous question), I need to create an Excel VBA Recordset from an Access query and filter its results using a user-defined function.
I thought I could use the following code to accomplish this:
Sub test()
Dim db As Database
Dim rs As Recordset
Dim rs_clone As Recordset
Set db = OpenDatabase(dbPath)
Set rs = db.OpenRecordset("select testVal from dataTable")
Set rs_clone = rs.Clone
rs_clone.MoveLast
rs_clone.MoveFirst
while not rs_clone.eof
if myUDF(rs_clone!testVal) then
rs_clone.delete
end if
rs_clone.moveNext
wend
End Sub
But that actually deletes values from my source table, so the clone isn't a new recordset that I can freely alter, it's just another pointer to the original one. How can I use my UDF to filter out the records I don't want, while leaving the original data untouched, if putting the UDF in the query itself is not an option?
In Access with DAO, this is how you'd do it:
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim rsFiltered As DAO.Recordset
Set db = CurrentDb
Set rs = db.OpenRecordset("SELECT tblInventory.* FROM tblInventory;")
rs.MoveLast
Debug.Print "Unfiltered: " & rs.RecordCount
rs.filter = "[LastUpdated]>=#1/1/2011#"
Set rsFiltered = rs.OpenRecordset
rsFiltered.MoveLast
Debug.Print "Filtered: " & rsFiltered.RecordCount
rsFiltered.Close
Set rsFiltered = Nothing
rs.Close
Set rs = Nothing
Set db = Nothing
However, note that (as mentioned in the help file), it may be just as fast to simply reopen the recordset with new criteria, instead of filtering the existing recordset.
Use the .getrows method:
Dim rs_clone As Variant
...
rs_clone = rs.getrows(numrows)
then process the resulting 2-d array.
Option Compare Database
Private Sub Command0_Click()
Sub Export_Click()
Dim db As Database, rs As Recordset, sql As String, r As Variant
Dim appExcel As Excel.Application
Dim excelWbk As Excel.Workbook
Dim excelSht As Object
Dim rng As Excel.Range
Set appExcel = New Excel.Application
On Error Resume Next
Set excelWbk = appExcel.Workbooks.Open("Folder Name(Template)")
Set db = CurrentDb()
sql1 = "Select * from Query_New"
sql2 = "Select * from Query_Expired"
Set rs1 = db.OpenRecordset(sql1, dbReadOnly)
Set rs2 = db.OpenRecordset(sql2, dbReadOnly)
Dim SheetName1 As String
Dim SheetName2 As String
SheetName1 = "New"
SheetName2 = "Expired"
'For first sheet
On Error Resume Next
excelWbk.Sheets(SheetName1).Select
If Err.Number <> 0 Then
MsgBox Err.Number
excelWbk.Close False
appExcel.Quit
Exit Sub
End If
With excelWbk.Activesheet
.Cells(5, 1).CopyFromRecordset rs1
On Error GoTo 0
End With
'For second sheet
On Error Resume Next
excelWbk.Sheets(SheetName2).Select
If Err.Number <> 0 Then
MsgBox Err.Number
excelWbk.Close False
appExcel.Quit
Exit Sub
End If
With excelWbk.Activesheet
.Cells(5, 1).CopyFromRecordset rs2
On Error GoTo 0
End With
rs1.Close
Set rs1 = Nothing
rs2.Close
Set rs2 = Nothing
db.Close
Set db = Nothing
On Error Resume Next
excelWbk.SaveAs "C:\Documents and settings\" & Environ("UserName") & "\Desktop\Decision.xlsx"
If Err.Number <> 0 Then
MsgBox Err.Number
End If
excelWbk.Close False
appExcel.Quit
Set appExcel = Nothing
MsgBox "The report has been saved"
End Sub
End Sub

Resources