How do I read a closed excel using VBA? - excel

I have a collection of .xls files in one folder. I wish to use VBA to extract values from these .xls while the files are closed.

If you are familiar with SQL then you can run queries against Excel files to get the data. It is much faster than opening an Excel file, but the data in your excel files needs to be well organized like a SQL table. Here is an example.
Write SQL query on excel tables

Import data from a closed workbook (ADO)
If you want to import a lot of data from a closed workbook you can do this with ADO and the macro below. If you want to retrieve data from another worksheet than the first worksheet in the closed workbook, you have to refer to a user defined named range. The macro below can be used like this (in Excel 2000 or later):
GetDataFromClosedWorkbook "C:\FolderName\WorkbookName.xls", "A1:B21", ActiveCell, False
GetDataFromClosedWorkbook "C:\FolderName\WorkbookName.xls", "MyDataRange", Range ("B3"), True
Sub GetDataFromClosedWorkbook(SourceFile As String, SourceRange As String, _
TargetRange As Range, IncludeFieldNames As Boolean)
' requires a reference to the Microsoft ActiveX Data Objects library
' if SourceRange is a range reference:
' this will return data from the first worksheet in SourceFile
' if SourceRange is a defined name reference:
' this will return data from any worksheet in SourceFile
' SourceRange must include the range headers
'
Dim dbConnection As ADODB.Connection, rs As ADODB.Recordset
Dim dbConnectionString As String
Dim TargetCell As Range, i As Integer
dbConnectionString = "DRIVER={Microsoft Excel Driver (*.xls)};" & _
"ReadOnly=1;DBQ=" & SourceFile
Set dbConnection = New ADODB.Connection
On Error GoTo InvalidInput
dbConnection.Open dbConnectionString ' open the database connection
Set rs = dbConnection.Execute("[" & SourceRange & "]")
Set TargetCell = TargetRange.Cells(1, 1)
If IncludeFieldNames Then
For i = 0 To rs.Fields.Count - 1
TargetCell.Offset(0, i).Formula = rs.Fields(i).Name
Next i
Set TargetCell = TargetCell.Offset(1, 0)
End If
TargetCell.CopyFromRecordset rs
rs.Close
dbConnection.Close ' close the database connection
Set TargetCell = Nothing
Set rs = Nothing
Set dbConnection = Nothing
On Error GoTo 0
Exit Sub
InvalidInput:
MsgBox "The source file or source range is invalid!", _
vbExclamation, "Get data from closed workbook"
End Sub
Another method that doesn't use the CopyFromRecordSet-method
With the macro below you can perform the import and have better control over the results returned from the RecordSet.
Sub TestReadDataFromWorkbook()
' fills data from a closed workbook in at the active cell
Dim tArray As Variant, r As Long, c As Long
tArray = ReadDataFromWorkbook("C:\FolderName\SourceWbName.xls", "A1:B21")
' without using the transpose function
For r = LBound(tArray, 2) To UBound(tArray, 2)
For c = LBound(tArray, 1) To UBound(tArray, 1)
ActiveCell.Offset(r, c).Formula = tArray(c, r)
Next c
Next r
' using the transpose function (has limitations)
' tArray = Application.WorksheetFunction.Transpose(tArray)
' For r = LBound(tArray, 1) To UBound(tArray, 1)
' For c = LBound(tArray, 2) To UBound(tArray, 2)
' ActiveCell.Offset(r - 1, c - 1).Formula = tArray(r, c)
' Next c
' Next r
End Sub
Private Function ReadDataFromWorkbook(SourceFile As String, SourceRange As String) As Variant
' requires a reference to the Microsoft ActiveX Data Objects library
' if SourceRange is a range reference:
' this function can only return data from the first worksheet in SourceFile
' if SourceRange is a defined name reference:
' this function can return data from any worksheet in SourceFile
' SourceRange must include the range headers
' examples:
' varRecordSetData = ReadDataFromWorkbook("C:\FolderName\SourceWbName.xls", "A1:A21")
' varRecordSetData = ReadDataFromWorkbook("C:\FolderName\SourceWbName.xls", "A1:B21")
' varRecordSetData = ReadDataFromWorkbook("C:\FolderName\SourceWbName.xls", "DefinedRangeName")
Dim dbConnection As ADODB.Connection, rs As ADODB.Recordset
Dim dbConnectionString As String
dbConnectionString = "DRIVER={Microsoft Excel Driver (*.xls)};ReadOnly=1;DBQ=" & SourceFile
Set dbConnection = New ADODB.Connection
On Error GoTo InvalidInput
dbConnection.Open dbConnectionString ' open the database connection
Set rs = dbConnection.Execute("[" & SourceRange & "]")
On Error GoTo 0
ReadDataFromWorkbook = rs.GetRows ' returns a two dim array with all records in rs
rs.Close
dbConnection.Close ' close the database connection
Set rs = Nothing
Set dbConnection = Nothing
On Error GoTo 0
Exit Function
InvalidInput:
MsgBox "The source file or source range is invalid!", vbExclamation, "Get data from closed workbook"
Set rs = Nothing
Set dbConnection = Nothing
End Function
http://www.erlandsendata.no/english/index.php?d=envbadacimportwbado
&
https://www.rondebruin.nl/win/s3/win024.htm

Related

Import to Specific Excel Sheet from Access via VBA

I am trying to figure out how to get data that I am importing into Excel from an Access table to import into a specific sheet (Either a sheet just called Sheet 2 or Access Data). I have the following code to get the data and to format it the way I want after import, but I can't get it to import into a specific sheet. Can I get assistance? Here's what I have:
Update to the code with resolution:
Sub getAccessData()
Dim DBFullName As String
Dim Connect As String, Source As String
Dim Connection As ADODB.Connection
Dim Recordset As ADODB.Recordset
Dim Col As Integer
Dim lngLastColumn As Long
Dim lngLastRow As Long
Dim OXLSheet As Worksheet
Set OXLSheet = Worksheets("WorksheetName")
Worksheets("WorksheetName").Cells.Clear
'Datebase path info
DBFullName = "C:\Users\myname\Desktop\Database Backups\database.accdb"
'Open the connection for the database
Set Connection = New ADODB.Connection
Connect = "Provider=Microsoft.ACE.OLEDB.12.0;"
Connect = Connect & "Data Source=" & DBFullName & ";"
Connection.Open ConnectionString:=Connect
'Create RecordSet
Set Recordset = New ADODB.Recordset
With Recordset
'Data Filter
Source = "SELECT * FROM tblRetirements WHERE [AllowEnteredInPayroll] Is Null AND ApplicationCancelled = 'No'"
.Open Source:=Source, ActiveConnection:=Connection
'Write field Names
For Col = 0 To Recordset.Fields.Count - 1
Worksheets("WorksheetName").Range("A5").Offset(0, Col).Value = Recordset.Fields(Col).Name
Next
'Write Recordset
Worksheets("WorksheetName").Range("A5").Offset(1, 0).CopyFromRecordset Recordset
End With
ActiveSheet.Columns.AutoFit
Set Recordset = Nothing
Connection.Close
Set Connection = Nothing
With OXLSheet
lngLastColumn = .Cells(5, .Columns.Count).End(xlToLeft).Column
lngLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
.ListObjects.Add(xlSrcRange, .Range(.Cells(5, 1), .Cells(lngLastRow, lngLastColumn)), , xlYes).Name = "Table1"
ActiveSheet.ListObjects("Table1").TableStyle = "TableStyleMedium16"
End With
End Sub
Thank you.
There is a typo, SELECT*FROM, should be SELECT * FROM.
If you want to import into a specific sheet, name output, please try replace:
Range("A5").Offset(0, Col).Value = Recordset.Fields(Col).Name with Worksheets("output").Range("A5").Offset(0, Col).Value = Recordset.Fields(Col).Name
Range("A5").Offset(1, 0).CopyFromRecordset Recordset with Worksheets("output").Range("A5").Offset(1, 0).CopyFromRecordset Recordset
If you want to copy your data in a specific worksheet, for instance named Sheet2
' Declare a worksheet object
Dim objSheet As Worksheet
' initialize it
Set objSheet = ActiveWorkbook.Sheets("Sheet2")
'Write field Names
For Col = 0 To Recordset.Fields.Count - 1
objSheet.Range("A5").Offset(0, Col).Value = Recordset.Fields(Col).Name
Next
'Write Recordset
objSheet.Range("A5").Offset(1, 0).CopyFromRecordset Recordset
Here is generic code to import the data from specific worksheets in all EXCEL files (worksheet names are the same in all files) that are located within a single folder. All of the EXCEL files' worksheets with the same worksheet names must have the data in the same layout and format.
Sub TryThis()
Dim strPathFile As String, strFile As String, strPath As String
Dim blnHasFieldNames As Boolean
Dim intWorksheets As Integer
' Replace 3 with the number of worksheets to be imported
' from each EXCEL file
Dim strWorksheets(1 To 3) As String
' Replace 3 with the number of worksheets to be imported
' from each EXCEL file (this code assumes that each worksheet
' with the same name is being imported into a separate table
' for that specific worksheet name)
Dim strTables(1 To 3) As String
' Replace generic worksheet names with the real worksheet names;
' add / delete code lines so that there is one code line for
' each worksheet that is to be imported from each workbook file
strWorksheets(1) = "GenericWorksheetName1"
strWorksheets(2) = "GenericWorksheetName2"
strWorksheets(3) = "GenericWorksheetName3"
' Replace generic table names with the real table names;
' add / delete code lines so that there is one code line for
' each worksheet that is to be imported from each workbook file
strTables(1) = "GenericTableName1"
strTables(2) = "GenericTableName2"
strTables(3) = "GenericTableName3"
' Change this next line to True if the first row in EXCEL worksheet
' has field names
blnHasFieldNames = False
' Replace C:\Documents\ with the real path to the folder that
' contains the EXCEL files
strPath = "C:\Documents\"
' Replace 3 with the number of worksheets to be imported
' from each EXCEL file
For intWorksheets = 1 To 3
strFile = Dir(strPath & "*.xls")
Do While Len(strFile) > 0
strPathFile = strPath & strFile
DoCmd.TransferSpreadsheet acImport, _
acSpreadsheetTypeExcel9, strTables(intWorksheets), _
strPathFile, blnHasFieldNames, _
strWorksheets(intWorksheets) & "$"
strFile = Dir()
Loop
Next intWorksheets
End Sub

Not able to pull records from access to excel, Probable connection issue

I using the below code to pull records from access to excel.
I am getting error at
connDB.Open ConnectionString:="Provider = Microsoft.ACE.OLEDB.12.0; data source=" & strDB
The error says"invalid sql statement, delete, insert,procedure,selet or update"
Kindly help as I am stuck and cannot move forward at all....
please help.
Sub automateAccessADO_9()
'Using ADO to Import data from an Access Database Table to an Excel worksheet (your host application).
'refer Image 9a to view the existing SalesManager Table in MS Access file "SalesReport.accdb".
'To use ADO in your VBA project, you must add a reference to the ADO Object Library in Excel (your host application) by clicking Tools-References in VBE, and then choose an appropriate version of Microsoft ActiveX Data Objects x.x Library from the list.
'--------------
'DIM STATEMENTS
Dim strMyPath As String, strDBName As String, strDB As String, strSQL As String
Dim i As Long, n As Long, lFieldCount As Long
Dim rng As Range
'instantiate an ADO object using Dim with the New keyword:
Dim adoRecSet As New ADODB.Recordset
Dim connDB As New ADODB.Connection
'--------------
'THE CONNECTION OBJECT
strDBName = "Computer.accdb"
strMyPath = ThisWorkbook.Path
strDB = strMyPath & "\" & strDBName
'Connect to a data source:
'For pre - MS Access 2007, .mdb files (viz. MS Access 97 up to MS Access 2003), use the Jet provider: "Microsoft.Jet.OLEDB.4.0". For Access 2007 (.accdb database) use the ACE Provider: "Microsoft.ACE.OLEDB.12.0". The ACE Provider can be used for both the Access .mdb & .accdb files.
connDB.Open ConnectionString:="Provider = Microsoft.ACE.OLEDB.12.0; data source=" & strDB
'--------------
'OPEN RECORDSET, ACCESS RECORDS AND FIELDS
Dim ws As Worksheet
'set the worksheet:
Set ws = ActiveWorkbook.Sheets("Sheet1")
'Set the ADO Recordset object:
Set adoRecSet = New ADODB.Recordset
'Opening the table named SalesManager:
strTable = "memory"
'--------------
'COPY RECORDS FROM ALL FIELDS OF A RECORDSET:
'refer Image 9d to view records copied to Excel worksheet
adoRecSet.Open Source:=strTable, ActiveConnection:=connDB, CursorType:=adOpenStatic, LockType:=adLockOptimistic
Set rng = ws.Range("A1")
lFieldCount = adoRecSet.Fields.Count
For i = 0 To lFieldCount - 1
'copy column names in first row of the worksheet:
rng.Offset(0, i).Value = adoRecSet.Fields(i).Name
adoRecSet.MoveFirst
'copy record values starting from second row of the worksheet:
n = 1
Do While Not adoRecSet.EOF
rng.Offset(n, i).Value = adoRecSet.Fields(i).Value
adoRecSet.MoveNext
n = n + 1
Loop
Next i
'select column range to AutoFit column width:
Range(ws.Columns(1), ws.Columns(lFieldCount)).AutoFit
'worksheet columns are deleted because this code is only for demo:
Range(ws.Columns(1), ws.Columns(lFieldCount)).Delete
adoRecSet.Close
'close the objects
connDB.Close
'destroy the variables
Set adoRecSet = Nothing
Set connDB = Nothing
End Sub
When going from Access to Excel, you have quite a few options!
Here's one way to EXPORT data from Access to Excel.
Dim lngColumn As Long
Dim xlx As Object, xlw As Object, xls As Object, xlc As Object
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim blnEXCEL As Boolean, blnHeaderRow As Boolean
blnEXCEL = False
' Replace True with False if you do not want the first row of
' the worksheet to be a header row (the names of the fields
' from the recordset)
blnHeaderRow = True
' Establish an EXCEL application object
On Error Resume Next
Set xlx = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
Set xlx = CreateObject("Excel.Application")
blnEXCEL = True
End If
Err.Clear
On Error GoTo 0
' Change True to False if you do not want the workbook to be
' visible when the code is running
xlx.Visible = True
' Replace C:\Filename.xls with the actual path and filename
' of the EXCEL file into which you will write the data
Set xlw = xlx.Workbooks.Open("C:\Filename.xls")
' Replace WorksheetName with the actual name of the worksheet
' in the EXCEL file
' (note that the worksheet must already be in the EXCEL file)
Set xls = xlw.Worksheets("WorksheetName")
' Replace A1 with the cell reference into which the first data value
' is to be written
Set xlc = xls.Range("A1") ' this is the first cell into which data go
Set dbs = CurrentDb()
' Replace QueryOrTableName with the real name of the table or query
' whose data are to be written into the worksheet
Set rst = dbs.OpenRecordset("QueryOrTableName", dbOpenDynaset, dbReadOnly)
If rst.EOF = False And rst.BOF = False Then
rst.MoveFirst
If blnHeaderRow = True Then
For lngColumn = 0 To rst.Fields.Count - 1
xlc.Offset(0, lngColumn).Value = rst.Fields(lngColumn).Name
Next lngColumn
Set xlc = xlc.Offset(1,0)
End If
' write data to worksheet
Do While rst.EOF = False
For lngColumn = 0 To rst.Fields.Count - 1
xlc.Offset(0, lngColumn).Value = rst.Fields(lngColumn).Value
Next lngColumn
rst.MoveNext
Set xlc = xlc.Offset(1,0)
Loop
End If
rst.Close
Set rst = Nothing
dbs.Close
Set dbs = Nothing
' Close the EXCEL file while saving the file, and clean up the EXCEL objects
Set xlc = Nothing
Set xls = Nothing
xlw.Close True ' close the EXCEL file and save the new data
Set xlw = Nothing
If blnEXCEL = True Then xlx.Quit
Set xlx = Nothing
Here's another way.
Dim lngColumn As Long
Dim xlx As Object, xlw As Object, xls As Object, xlc As Object
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim strPathFileName As String, strWorksheetName As String
Dim strRecordsetDataSource As String
Dim blnEXCEL As Boolean, blnHeaderRow As Boolean
blnEXCEL = False
' Replace C:\Filename.xls with the actual path and filename
' that will be used to save the new EXCEL file into which you
' will write the data
strPathFileName = "C:\Filename.xls"
' Replace QueryOrTableName with the real name of the table or query
' whose data are to be written into the worksheet
strRecordsetDataSource = "QueryOrTableName"
' Replace True with False if you do not want the first row of
' the worksheet to be a header row (the names of the fields
' from the recordset)
blnHeaderRow = True
' Establish an EXCEL application object
On Error Resume Next
Set xlx = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
Set xlx = CreateObject("Excel.Application")
blnEXCEL = True
End If
Err.Clear
On Error GoTo 0
' Change True to False if you do not want the workbook to be
' visible when the code is running
xlx.Visible = True
' Create a new EXCEL workbook
Set xlw = xlx.Workbooks.Add
' Rename the first worksheet in the EXCEL file to be the first 31
' characters of the string in the strRecordsetDataSource variable
Set xls = xlw.Worksheets(1)
xls.Name = Trim(Left(strRecordsetDataSource, 31))
' Replace A1 with the cell reference of the first cell into which the
' headers will be written (blnHeaderRow = True), or into which the data
' values will be written (blnHeaderRow = False)
Set xlc = xls.Range("A1")
Set dbs = CurrentDb()
Set rst = dbs.OpenRecordset(strRecordsetDataSource, dbOpenDynaset, dbReadOnly)
If rst.EOF = False And rst.BOF = False Then
' Write the header row to worksheet
If blnHeaderRow = True Then
For lngColumn = 0 To rst.Fields.Count - 1
xlc.Offset(0, lngColumn).Value = rst.Fields(lngColumn).Name
Next lngColumn
Set xlc = xlc.Offset(1,0)
End If
' copy the recordset's data to worksheet
xlc.CopyFromRecordset rst
End If
rst.Close
Set rst = Nothing
dbs.Close
Set dbs = Nothing
' Save and close the EXCEL file, and clean up the EXCEL objects
Set xlc = Nothing
Set xls = Nothing
xlw.SaveAs strPathFileName
xlw.Close False
Set xlw = Nothing
If blnEXCEL = True Then xlx.Quit
Set xlx = Nothing
Here's a way to IMPORT date from Access to Excel.
Sub ADOImportFromAccessTable(DBFullName As String, _
TableName As String, TargetRange As Range)
' Example: ADOImportFromAccessTable "C:\FolderName\DataBaseName.mdb", _
"TableName", Range("C1")
Dim cn As ADODB.Connection, rs As ADODB.Recordset, intColIndex As Integer
Set TargetRange = TargetRange.Cells(1, 1)
' open the database
Set cn = New ADODB.Connection
cn.Open "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & _
DBFullName & ";"
Set rs = New ADODB.Recordset
With rs
' open the recordset
.Open TableName, cn, adOpenStatic, adLockOptimistic, adCmdTable
' all records
'.Open "SELECT * FROM " & TableName & _
" WHERE [FieldName] = 'MyCriteria'", cn, , , adCmdText
' filter records
RS2WS rs, TargetRange ' write data from the recordset to the worksheet
' ' optional approach for Excel 2000 or later (RS2WS is not necessary)
' For intColIndex = 0 To rs.Fields.Count - 1 ' the field names
' TargetRange.Offset(0, intColIndex).Value = rs.Fields(intColIndex).Name
' Next
' TargetRange.Offset(1, 0).CopyFromRecordset rs ' the recordset data
End With
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
End Sub
Here's one more way to IMPORT your data.
Sub DAOCopyFromRecordSet(DBFullName As String, TableName As String, _
FieldName As String, TargetRange As Range)
' Example: DAOCopyFromRecordSet "C:\FolderName\DataBaseName.mdb", _
"TableName", "FieldName", Range("C1")
Dim db As Database, rs As Recordset
Dim intColIndex As Integer
Set TargetRange = TargetRange.Cells(1, 1)
Set db = OpenDatabase(DBFullName)
Set rs = db.OpenRecordset(TableName, dbOpenTable) ' all records
'Set rs = db.OpenRecordset("SELECT * FROM " & TableName & _
" WHERE " & FieldName & _
" = 'MyCriteria'", dbReadOnly) ' filter records
' write field names
For intColIndex = 0 To rs.Fields.Count - 1
TargetRange.Offset(0, intColIndex).Value = rs.Fields(intColIndex).Name
Next
' write recordset
TargetRange.Offset(1, 0).CopyFromRecordset rs
Set rs = Nothing
db.Close
Set db = Nothing
End Sub

import excel file using something similiar to QueryTable?

To import data into an excel file, QueryTable is quite convenient when the source is a .csv file, e.g. Import csv with quoted newline using QueryTables in Excel , however it does not work with excel sources.
Importing an excel file can be done by VBA, just wonder, if there's something convenient as QueryTable, to import from a excel file, s.t. only need to specify the source file name, sheet name or range name?
Oh, I see. Ok, well, you can use VBA to import data from Worksheets into your Workbook.
' Get customer workbook...
Dim customerBook As Workbook
Dim filter As String
Dim caption As String
Dim customerFilename As String
Dim customerWorkbook As Workbook
Dim targetWorkbook As Workbook
' make weak assumption that active workbook is the target
Set targetWorkbook = Application.ActiveWorkbook
' get the customer workbook
filter = "Text files (*.xlsx),*.xlsx"
caption = "Please Select an input file "
customerFilename = Application.GetOpenFilename(filter, , caption)
Set customerWorkbook = Application.Workbooks.Open(customerFilename)
' assume range is A1 - C10 in sheet1
' copy data from customer to target workbook
Dim targetSheet As Worksheet
Set targetSheet = targetWorkbook.Worksheets(1)
Dim sourceSheet As Worksheet
Set sourceSheet = customerWorkbook.Worksheets(1)
targetSheet.Range("A1", "C10").Value = sourceSheet.Range("A1", "C10").Value
' Close customer workbook
customerWorkbook.Close
Or, you can use the Query tool to import data from another Excel file.
http://dailydoseofexcel.com/archives/2004/12/13/parameters-in-excel-external-data-queries/
I'm guessing you are importing data from Access into excel. I don't think you specified your source, or I couldn't make it out. My eyes are not as good as they used to be...
Anyway, consider this option.
Sub ADOImportFromAccessTable(DBFullName As String, _
TableName As String, TargetRange As Range)
' Example: ADOImportFromAccessTable "C:\FolderName\DataBaseName.mdb", _
"TableName", Range("C1")
Dim cn As ADODB.Connection, rs As ADODB.Recordset, intColIndex As Integer
Set TargetRange = TargetRange.Cells(1, 1)
' open the database
Set cn = New ADODB.Connection
cn.Open "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & _
DBFullName & ";"
Set rs = New ADODB.Recordset
With rs
' open the recordset
.Open TableName, cn, adOpenStatic, adLockOptimistic, adCmdTable
' all records
'.Open "SELECT * FROM " & TableName & _
" WHERE [FieldName] = 'MyCriteria'", cn, , , adCmdText
' filter records
RS2WS rs, TargetRange ' write data from the recordset to the worksheet
' ' optional approach for Excel 2000 or later (RS2WS is not necessary)
' For intColIndex = 0 To rs.Fields.Count - 1 ' the field names
' TargetRange.Offset(0, intColIndex).Value = rs.Fields(intColIndex).Name
' Next
' TargetRange.Offset(1, 0).CopyFromRecordset rs ' the recordset data
End With
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
End Sub
Or, this.
Sub RS2WS(rs As ADODB.Recordset, TargetCell As Range)
Dim f As Integer, r As Long, c As Long
If rs Is Nothing Then Exit Sub
If rs.State <> adStateOpen Then Exit Sub
If TargetCell Is Nothing Then Exit Sub
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.StatusBar = "Writing data from recordset..."
End With
With TargetCell.Cells(1, 1)
r = .Row
c = .Column
End With
With TargetCell.Parent
.Range(.Cells(r, c), .Cells(.Rows.Count, c + rs.Fields.Count - 1)).Clear
' clear existing contents
' write column headers
For f = 0 To rs.Fields.Count - 1
On Error Resume Next
.Cells(r, c + f).Formula = rs.Fields(f).Name
On Error GoTo 0
Next f
' write records
On Error Resume Next
rs.MoveFirst
On Error GoTo 0
Do While Not rs.EOF
r = r + 1
For f = 0 To rs.Fields.Count - 1
On Error Resume Next
.Cells(r, c + f).Formula = rs.Fields(f).Value
On Error GoTo 0
Next f
rs.MoveNext
Loop
.Rows(TargetCell.Cells(1, 1).Row).Font.Bold = True
.Columns("A:IV").AutoFit
End With
With Application
.StatusBar = False
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub

Access - VBA - Cannot import new excel file - but can after opening it once

I'm using some VBA to import an excel file into Access.
Public Sub ImportExcelSpreadsheet(fileName As String, tableName As String)
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, tableName, fileName, True, "A5:H5000"
End Sub
And:
Private Sub btnBrowse_Click()
Dim diag As Office.FileDialog
Dim Item As Variant
Set diag = Application.FileDialog(msoFileDialogFilePicker)
diag.AllowMultiSelect = False
diag.Title = "Please select your excel file"
diag.Filters.Clear
diag.Filters.Add "Excel files", "*.xls, *.xlsx"
If diag.Show Then
For Each Item In diag.SelectedItems
Me.txtFileName = Item
Next
End If
End Sub
The problem is as follows:
I extract an excel file from one of the applications we have running here. It's a 97-2003 .xls file.
If I do not open the file in excel first my access app will not import it, throwing a "table is in unexpected format"-error. If I open the excel file once in excel itself and close it (without altering or saving it) access will then accept the file.
I have other 97-2003 excel files exported from other applications which work fine without having to open them once...am at a loss here.
I've tried using acSpreadsheetTypeExcel8 and 9 instead. No luck.
The excel file is also not a .htm in disguise.
Does anyone here have any suggestions?
Can you export from Excel to Access using ADO???
Sub ADOFromExcelToAccess()
' exports data from the active worksheet to a table in an Access database
' this procedure must be edited before use
Dim cn As ADODB.Connection, rs As ADODB.Recordset, r As Long
' connect to the Access database
Set cn = New ADODB.Connection
cn.Open "Provider=Microsoft.Jet.OLEDB.4.0; " & _
"Data Source=C:\FolderName\DataBaseName.mdb;"
' open a recordset
Set rs = New ADODB.Recordset
rs.Open "TableName", cn, adOpenKeyset, adLockOptimistic, adCmdTable
' all records in a table
r = 3 ' the start row in the worksheet
Do While Len(Range("A" & r).Formula) > 0
' repeat until first empty cell in column A
With rs
.AddNew ' create a new record
' add values to each field in the record
.Fields("FieldName1") = Range("A" & r).Value
.Fields("FieldName2") = Range("B" & r).Value
.Fields("FieldNameN") = Range("C" & r).Value
' add more fields if necessary...
.Update ' stores the new record
End With
r = r + 1 ' next row
Loop
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
End Sub
Can you do the same using DAO???
Sub DAOFromExcelToAccess()
' exports data from the active worksheet to a table in an Access database
' this procedure must be edited before use
Dim db As Database, rs As Recordset, r As Long
Set db = OpenDatabase("C:\FolderName\DataBaseName.mdb")
' open the database
Set rs = db.OpenRecordset("TableName", dbOpenTable)
' get all records in a table
r = 3 ' the start row in the worksheet
Do While Len(Range("A" & r).Formula) > 0
' repeat until first empty cell in column A
With rs
.AddNew ' create a new record
' add values to each field in the record
.Fields("FieldName1") = Range("A" & r).Value
.Fields("FieldName2") = Range("B" & r).Value
.Fields("FieldNameN") = Range("C" & r).Value
' add more fields if necessary...
.Update ' stores the new record
End With
r = r + 1 ' next row
Loop
rs.Close
Set rs = Nothing
db.Close
Set db = Nothing
End Sub
Can you import to Access form a closed Workbook???
GetDataFromClosedWorkbook "C:\FolderName\WorkbookName.xls", "A1:B21", ActiveCell, False
GetDataFromClosedWorkbook "C:\FolderName\WorkbookName.xls", "MyDataRange", Range ("B3"), True
Sub GetDataFromClosedWorkbook(SourceFile As String, SourceRange As String, _
TargetRange As Range, IncludeFieldNames As Boolean)
' requires a reference to the Microsoft ActiveX Data Objects library
' if SourceRange is a range reference:
' this will return data from the first worksheet in SourceFile
' if SourceRange is a defined name reference:
' this will return data from any worksheet in SourceFile
' SourceRange must include the range headers
'
Dim dbConnection As ADODB.Connection, rs As ADODB.Recordset
Dim dbConnectionString As String
Dim TargetCell As Range, i As Integer
dbConnectionString = "DRIVER={Microsoft Excel Driver (*.xls)};" & _
"ReadOnly=1;DBQ=" & SourceFile
Set dbConnection = New ADODB.Connection
On Error GoTo InvalidInput
dbConnection.Open dbConnectionString ' open the database connection
Set rs = dbConnection.Execute("[" & SourceRange & "]")
Set TargetCell = TargetRange.Cells(1, 1)
If IncludeFieldNames Then
For i = 0 To rs.Fields.Count - 1
TargetCell.Offset(0, i).Formula = rs.Fields(i).Name
Next i
Set TargetCell = TargetCell.Offset(1, 0)
End If
TargetCell.CopyFromRecordset rs
rs.Close
dbConnection.Close ' close the database connection
Set TargetCell = Nothing
Set rs = Nothing
Set dbConnection = Nothing
On Error GoTo 0
Exit Sub
InvalidInput:
MsgBox "The source file or source range is invalid!", _
vbExclamation, "Get data from closed workbook"
End Sub
Finally...can you browse to an Excel file and import data from that file???
Dim strPathFile As String
Dim strTable As String, strBrowseMsg As String
Dim strFilter As String, strInitialDirectory As String
Dim blnHasFieldNames As Boolean
' Change this next line to True if the first row in EXCEL worksheet
' has field names
blnHasFieldNames = False
strBrowseMsg = "Select the EXCEL file:"
' Change C:\MyFolder\ to the path for the folder where the Browse
' window is to start (the initial directory). If you want to start in
' ACCESS' default folder, delete C:\MyFolder\ from the code line,
' leaving an empty string as the value being set as the initial
' directory
strInitialDirectory = "C:\MyFolder\"
strFilter = ahtAddFilterItem(strFilter, "Excel Files (*.xls)", "*.xls")
strPathFile = ahtCommonFileOpenSave(InitialDir:=strInitialDirectory, _
Filter:=strFilter, OpenFile:=False, _
DialogTitle:=strBrowseMsg, _
Flags:=ahtOFN_HIDEREADONLY)
If strPathFile = "" Then
MsgBox "No file was selected.", vbOK, "No Selection"
Exit Sub
End If
' Replace tablename with the real name of the table into which
' the data are to be imported
strTable = "tablename"
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, _
strTable, strPathFile, blnHasFieldNames
' Uncomment out the next code step if you want to delete the
' EXCEL file after it's been imported
' Kill strPathFile
Try these examples and post back with your findings.

copyfromrecordset returns blank column

I am creating an ADODB connection to a Sybase database, executing an SQL statement into a recordset, and then using the CopyFromRecordset method to paste the contents of the recordset to a range. This has been working fine but I recently moved PC's at work and now one of the columns is returning nothing.
When I run the same SQL in SQuirreL the column is not blank.
If I pause the VBA and try to look at one of the values in the column / field in question (ie ?rst.fields(1).value in the immediate Window) I get the following error message:
Run-time error '-2147467259 (80004005)': Unspecified error.
In the Squirrel results Metadata tab the column in question is described as:
ColumnIndex 2
getColumnName CommentText
getColumnTypeName text
getPrecision 2147483647
getScale 0
isNullable 0
getTableName xxxxxxx
getSchemaName
getCatalogName
getColumnClassName java.sql.Clob
getColumnDisplaySize 2147483647
getColumnLabel CommentText
getColumnType 2005
isAutoIncrement FALSE
isCaseSensitive FALSE
isCurrency FALSE
isDefinitelyWritable FALSE
isReadOnly FALSE
isSearchable FALSE
isSigned FALSE
isWritable TRUE
The code in question is below, but, as stated the code does not seem to be the problem as it has worked previously - any ideas?
Sub ImportComments()
Dim wsData As Worksheet
Dim rng As Range
Dim cn As ADODB.Connection
Dim rst As ADODB.Recordset
Dim x As Long
Dim rngSQL As Range
Dim cell As Range
Dim sSQL As String
Dim sProvider As String
Dim sDS As String
Dim sDataSource As String
Dim sUser As String
Dim sCatalog As String
Dim sPassword As String
Dim rngDS As Range
Dim rngThisDS As Range
Dim sConnect As String
Dim sInstance As String
Dim fSuccess As Boolean
Dim sError As String
On Error GoTo ProcExit
'delete previous comments if they exist
If SheetExists("Comments_Data_Import", ThisWorkbook) = True Then
Application.DisplayAlerts = False
ThisWorkbook.Sheets("Comments_Data_Import").Delete
Application.DisplayAlerts = True
End If
'create comments sheet
Set wsData = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Sheets("EWI_Data_Import"))
wsData.Name = "Comments_Data_Import"
'build sql string
Set rngSQL = Range(ThisWorkbook.Sheets("SQL").Range("A2"), _
ThisWorkbook.Sheets("SQL").Range("A2").End(xlDown))
For Each cell In rngSQL
sSQL = sSQL & cell.Value & " "
Next cell
'define login components
Set rngDS = ThisWorkbook.Worksheets("Login").Range("rngInstance").CurrentRegion
Set rngDS = rngDS.Offset(1, 0).Resize(rngDS.Rows.Count - 1)
sProvider = "Provider=ASEOLEDB.1;"
sUser = "User ID=" & ThisWorkbook.Worksheets("Login").Range("rngUsername").Value & ";"
sPassword = "Password=" & ThisWorkbook.Worksheets("Login").Range("rngPassword").Value
'try to log in to each instance exiting when succesful
Set cn = New ADODB.Connection
cn.CommandTimeout = 600
'turn off error hadling to allow for connection errors On Error Resume Next
For Each rngThisDS In rngDS.Rows
'complete connect string
Err = 0
sInstance = rngThisDS.Cells(1, 1)
sDS = "Data Source=" & rngThisDS.Cells(1, 2) & ";"
sCatalog = "Initial Catalog=" & rngThisDS.Cells(1, 3) & ";"
sConnect = sProvider & sDS & sUser & sCatalog & sPassword
'attempt to open
cn.Open sConnect
'If successful Then
If Err = 0 Then
'flag success
fSuccess = True
'execute SQL
On Error GoTo ProcError
Set rst = cn.Execute(sSQL)
'copy data into comments sheet
wsData.Range("A2").CopyFromRecordset rst
'Put in the headers
Set rng = wsData.Range("A1")
For x = 1 To rst.Fields.Count
rng.Offset(0, x - 1).Value = rst.Fields(x - 1).Name
Next x
FormatComments
Exit For
End If
Next rngThisDS
If fSuccess = False Then
MsgBox ("Unable to connect to Insight")
Else
MsgBox "Connected to and exported data from " & sInstance
End If
ProcExit:
Set wsData = Nothing
Set rng = Nothing
Set cn = Nothing
Set rst = Nothing
Set rngSQL = Nothing
Set cell = Nothing
Set rngDS = Nothing
Set rngThisDS = Nothing
Exit Sub
ProcError:
MsgBox "Error: " & Err.Description
Resume ProcExit
End Sub
According to the CopyFromRecordset() MSDN:
When this method copies the recordset to the worksheet, the results
will be truncated if you do not specify a range that is large enough
to hold the contents of the recordset.
Consider specifying the range with MoveFirst command reset:
' Copy data into comments sheet
rst.MoveLast
rst.MoveFirst
wsData.Range("A2:Z500").CopyFromRecordset rst
Or entire worksheet (starting at A1, of course inserting row for column headers)
wsData.Cells.CopyFromRecordset rst
But even then, CopyFromRecordset() is sensitive to data and cursory types even memory (since you pull all data and dump at once), so consider altogether replacing the method and iterate through records for the rows. Even other languages (PHP, Python, Java, etc.) run queries this way, opening cursor and iterating through resultset.
' Put in the headers
Set rng = wsData.Range("A1")
For x = 1 To rst.Fields.Count
rng.Offset(0, x - 1).Value = rst.Fields(x - 1).Name
Next x
' Put in rows
Dim col As Integer, row As Integer
rst.MoveLast
rst.MoveFirst
Set rng = wsData.Range("A2")
row = 0
Do While Not rst.EOF
For col = 0 To rst.Fields.Count - 1
rng.Offset(row, col).Value = rst(col)
Next col
row = row + 1
rst.MoveNext
Loop

Resources