WIA with Access VBA slow - ms-access

I have a macro running in MS Access 2013 which was created to scan documents from an HP Scanjet Enterprise Flow 7500 scanner, save the results as a PDF and automatically email the file to someone else in our organization.
The macro itself runs as it should, however compared to the HP software which comes with the scanner, the scanning portion of the macro takes much longer. With the HP software, the time to scan 23 pages was about 30 seconds. With the macro, I had about 3-4 sheets scanned in that time. Please find below the code I'm using to control the scanner. Does anyone see anything that could be improved or changed to increase the speed of execution?
Const WIA_FORMAT_JPEG = "{B96B3CAE-0728-11D3-9D7B-0000F81EF32E}"
Private Sub cmdOK_Click()
Dim intPages As Integer 'number of pages
Dim img As wia.ImageFile
Dim strPath As String
Dim strPathImg As String
Dim strFileJPG As String
Dim txt_id As String
Dim strRPTScan As String
strPath = "H:\Scan\" 'set path to save files
strPathImg = "H:\Scan\Images\"
intPages = 1
On Error GoTo ErrorHandler
'scan
ScanStart:
Dim DialogScan As New wia.CommonDialog
Dim DPI As Integer
Dim PP As Integer
Dim l As Integer
Dim Scanner As wia.Device
Dim intVerticalExtent As Integer
Dim intOneTwoSided As Integer
Set Scanner = DialogScan.ShowSelectDevice(wia.WiaDeviceType.ScannerDeviceType, False, False)
'Set page length
Select Case fraPaperFormat
Case 1
intVerticalExtent = 1650
strRPTScan = "rptScan11"
Case 2
intVerticalExtent = 2100
strRPTScan = "rptScan14"
End Select
'Set single or two-sided scanning
Select Case fraSingleTwoSided
Case 1
intOneTwoSided = 1
Case 2
intOneTwoSided = 5
End Select
'Set scanner properties depending on userform letter format values
With Scanner
.Properties("3088").Value = intOneTwoSided 'determined above
.Items(1).Properties("Horizontal Resolution").Value = 150
.Items(1).Properties("Vertical Resolution").Value = 150
.Items(1).Properties("6149").Value = 0 'x point to start scan
.Items(1).Properties("6150").Value = 0 'y point to start scan
.Items(1).Properties("Horizontal Extent").Value = 1275
.Items(1).Properties("Vertical Extent").Value = intVerticalExtent 'determined above
End With
'Start Scan if err number -2145320957 Scan document finish
Do While Err.Number <> -2145320957 'error number is ADF status don't feed document
On Error GoTo here
Set img = Scanner.Items(1).Transfer(WIA_FORMAT_JPEG)
strFileJPG = strPathImg & CStr(intPages) & ".jpg"
img.SaveFile (strFileJPG) 'save files .jpg in temp folder
DoCmd.SetWarnings False
DoCmd.RunSQL "insert into scantemp (picture) values ('" & strFileJPG & "')" 'insert picture temp to table scan temp
intPages = intPages + 1 'add number pages
here:
Loop
'after finish scan start convert to pdf
Any help would be appreciated.

Obviously, the HP application can do a faster job than any VBA code, as the HP application can probably command the scanner to scan all the pages in the ADF, and you're just doing it one by one. As far as I know, using WIA, you can't work around this.
One way you might be able to optimize your code, is to first scan all the images and add them to a collection, then to save all the files in the collection to temporary files, then add them to the database in a single query, instead of processing each image separately.
A more optimized scanning solution would implement multithreading to scan and process scans simultaneously. VBA has no native implementation of multithreading, but there are a couple of solutions around there on the web, each having their own limitations.

Related

MS Access: Unzip a document stored as BLOB in memory using VBA

I have an MS Access table which stores zipped text documents in a BLOB column (long binary data) named XML. Each blob contains the binary representation of a zip archive (deflate) containing exactly one document named DOCUMENT. I would like to read the contents of the BLOB, unzip it and return the contents of DOCUMENT as a string in VBA, without the need to cache and unzip the archive on disk (I have managed to do that, but the process is very slow and inelegant).
I have tried downloading and referencing zlibwapi.dll as suggested here: http://www.xtremevbtalk.com/excel/318843-uncompress-compressed-string-using-zlib-vba.html
The DLL calls seem to work, but unfortunately I cannot get the code to unzip my data:
Sub Test()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Set db = CurrentDb
Set rs = CurrentDb.OpenRecordset("SELECT * FROM MYTABLE WHERE REFERENCE_ID = 28804")
Dim aByteData() As Byte
Dim sStringData As String
Dim res As Variant
With rs
.MoveFirst
While Not .EOF
aByteData = rs!xml
res = DecompressData(aByteData, rs!xml_lu)
.MoveNext
Wend
.Close
End With
Set rs = Nothing
MsgBox "Done.", vbInformation
End Sub
Before calling DecompressData, aByteData contains the correct sequence of bytes of my zipped document. After calling DecompressData, res is equal to -3 and aByteData is an array of zeroes.
Does anyone out there have any experience with zlibwapi.dll and how to get it to work in VBA? Any idea what exit code -3 means?
Update:
This fork of minizip seems to go in the right direction, though I have to idea of how to get it to work in VBA:
https://github.com/nmoinvaz/minizip

Access VBA DAO | ADO Bloating Database on MakeTable Query

I have a process that updates an Access Database from Oracle data three times a day to get latest information. Current production process involves:
Create New Access Table (t1) of Most Current Data
Move Previous Version of Data to backup version (t to t2)
Move Current Data to Main table (t1 to t)
The reason it's done this way is in case the current data fails, users can still access earlier version of data until we can troubleshoot current data or until the next run.
There are many of the processes that we inherited and I am refactoring the process so we can trap and alert errors and stop downstream processes from running when earlier processes fail.
I've developed the following function using DAO so that I can take advantage of Execute to trap errors and bow out of the whole process gracefully. However, this process bloats the database greatly and in all my searching I cannot find a way around this. Most of the research I have done points to clearing out DAO.Recordsets and DAO.QueryDefs, neither of which I deal with in the DDL statements. I created a similar function with ADO as well, but the same issue persists.
Is there any way to clear the temp memory created in Access from this statements after executing so the code can continue without have the DB grow beyond 2GB size limit? Or perhaps it's just better to run the queries with DoCmd.RunSQL and build error trapping with GoTo. I'd like to avoid this but will settle on this if it's the only way.
Function below:
Function ExecuteSQL(db As DAO.Database, sQuery As String) As Boolean
'*******************************************************************
'** Sub: ExecuteSQL
'** Purpose: Stores current copy of Daily Eff Date table from Daily Eff Table1 and backs up previous version in Daily Eff Date2
'** Notes: Requires reference to Microsoft DAO 3.6 Object Library (or equivalent)
'*******************************************************************
Dim wSpace As DAO.Workspace
Set wSpace = DBEngine.Workspaces(0)
On Error GoTo ErrHandler
With wSpace
.BeginTrans
db.Execute sQuery, dbFailOnError
.CommitTrans
ExecuteSQL = True
End With
LeaveExecuteSQL:
wSpace.Close
Exit Function
ErrHandler:
wSpace.Rollback
Resume LeaveExecuteSQL
End Function
Here is an example of how Function is called.
If Not ExecuteSQL(CurrentDb, "Daily Sub ALL") Then 'Bring Submission Data into Access
strSubject = "ERROR in Creating The Daily Effective Date Table"
GoTo LeaveRunProcess
End If
Here is SQL for Daily Sub ALL:
SELECT PRODCT_EFF_DT, Left([DWCFEUL5_DEV_SUB_RPT_STATUS_SUBM_ALL_NM]![PRODUCT_SIC_CD],4) AS Expr1, Left([PRODUCT_SIC_CD],4) AS [SIC Short], INS_RQMT_PRODCT_NO, CMPNY_REGN_NM, PROCESSING_REGION, PROCESSING_RGN_NM, CMPNY_CD, CMPNY_NM, PUC_NAME, UW_REGION_NAME, PUC_NO, CLIENT_NAME, CLIENT_NUMBER, ACCOUNT_NUMBER, DUNS_NUMBER, DUNS_PARENT, PRODUCER_NUMBER, PRODUCER_NAME, PRODUCER_CONTACT, PRODCR_CNTCT_PRSN_NO, PRODUCT_TYPE, BRANCH_TYPE, BRANCH_NAME, DEPT_NO, NEW_DEPT_NO, DEPT_CD, DEPT_NM, NEW_DEPT_NM, NEW_PRFT_CENTR_NO, PROFT_CNTR_NM, NEW_PRFT_CENTR_NM, EXP_POLICY_NO, EXPPOLICYNO10, POLICY_NO, POLICYNO10, PRODCT_ATCHMT_PNT_AMT, DED_AMT, LMT_AMT, PRODCT_EXP_DT, QUOTE_BY_DT, PRODCT_DESIRBLTY, NEW_PRODCR_NM, PRODCT_SUCCESS_CHNC, WIN_CARR_NAME, INCUMBENT_INS_CARR, PRODCT_EFF_MONTH, LINE_OF_BUSINESS, PRODCT_NO, PROFIT_CENTER, EXP_PREMIUM, UNDERWRITER_NAME, EMPL_ID, STATE, LAST_UPDT_TS, PREM_AMT, DT_RECEIVED, DT_RESERVED, DT_ASSIGNED, DT_WORKING, DT_QUOTED, DT_BOUND, DT_ISSUED, DT_BOOKED, DT_MAILED, DT_DECLINED, DT_QUOTE_NOT_WRITTEN, CURR_STATUS, CURR_STATUS_CD, CURR_STATUS_CHG_USR, CURR_STATUS_EFF_DT, UW_ASISTANT_NAME, COMPANY_TYPE, CREATE_DT, CREATE_USR, PRM_FINCG_IND, BNKRPCY_STAT_CD, BRKR_MNSCRPT_FORMS_IND, UNDLYG_CNF_WRITN_IND, PRODUCT_SIC_CD, ACCT_SIC, ACCT_SIC_DESC, ACCT_SIC_PCT, PROG_TYP_CD, EXT_REPT_IND, MOT_TRK_LIAB_FIL, MOT_TRK_CRG_FIL, SUBJ_TO_AUDIT, COMP_RATED_IND, CONSENT_TO_RATE, IND_RISK_RATING, NY_FREE_TRD_ZONE, EPOL_DELIVERED, PAYDEX_SCORE, CREDIT_SCORE, FINANCIAL_STRESS_SCORE, YEARS_IN_BUSINESS, DNB_NO, DNB_NAME, DNB_PARENT_NO, DNB_HEADQUARTERS_NO, DNB_ADDRESS_LINE1, DNB_ADDRESS_LINE2, DNB_ZIPCODE, DNB_CITY, DNB_STATE, DNB_COUNTRY_CODE, COMMERCIAL_CREDIT_SCORE, START_YEAR, CURRENT_CONTROL_YEAR, NAICS_CODE, INSRD_NM, PRODCR_LONG_NAME, SIR_AMOUNT, EMAIL_ADDRS_TXT, SUB_PRODUCER_NO, SUB_PRODUCER_CODE, SUB_PRODUCER_NM, SUB_PRODUCER_ADDRESS_LINE1, SUB_PRODUCER_ADDRESS_LINE2, SUB_PRODUCER_ADDRESS_LINE3, SUB_PRODUCER_CITY, SUB_PRODUCER_STATE, SUB_PRODUCER_ZIPCODE, PRODUCER_PHONE_NO, SHOPPING, ASSOC_NO, VIABILITY_SCORE, POLICY_ISSUED_BY, ASSOCIATE_UW, FEIN_N0, PRODUCER_FEIN
INTO [Daily Eff Date1]
FROM DWCFEUL5_DEV_SUB_RPT_STATUS_SUBM_ALL_NM
WHERE (((PRODCT_EFF_DT)>#1/1/2015#) AND ((NEW_PRFT_CENTR_NM) Not Like "Hawaii"));
NOT AN ANSWER SUPPORT FOR COMMENT
Option Compare Database
Private WithEvents conCUSTOM_CONNECTION As ADODB.CONNECTION
Public Event evtEXECUTEERROR(ByVal pError As ADODB.Error)
Public Event evtEXECUTESUCCESS()
Public Sub INITIALISE_CONNECTION(con As ADODB.CONNECTION)
Set conCUSTOM_CONNECTION = con
End Sub
Private Sub conCUSTOM_CONNECTION_ExecuteComplete(ByVal RecordsAffected As Long, _
ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, _
ByVal pCommand As ADODB.Command, ByVal pRecordset As ADODB.Recordset, _
ByVal pConnection As ADODB.CONNECTION)
If pError Is Nothing Then
RaiseEvent evtEXECUTESUCCESS
Else
RaiseEvent evtEXECUTEERROR(pError)
End If
End Sub
I have encountered the same issue where my database is bloating on raw data import. VBA is not allowed to call Compact & Repair on a non-split database. Instead of splitting the database and compacting the backend routinely, I decided to use the database object (DAO) to create a temp database, import the data, query from that temp database back to original and then delete the temp database. Base code shown below:
Sub tempAccessDatabaseImport()
Dim mySQL As String
Dim tempDBPath As String
Dim myWrk As DAO.Workspace
Dim tempDB As DAO.Database
Dim myObject
'Define temp access database path
tempPathArr = Split(Application.CurrentProject.Path, "\")
For i = LBound(tempPathArr) To UBound(tempPathArr)
tempDBPath = tempDBPath + tempPathArr(i) + "\"
Next i
tempDBPath = tempDBPath + "tempDB.accdb"
'Delete temp access database if exists
Set myObject = CreateObject("Scripting.FileSystemObject")
If myObject.FileExists(tempDBPath) Then
myObject.deleteFile (tempDBPath)
End If
'Open default workspace
Set myWrk = DBEngine.Workspaces(0)
'DAO Create database
Set tempDB = myWrk.CreateDatabase(tempDBPath, dbLangGeneral)
'DAO - Import temp xlsx into temp Access table
mySQL = "SELECT * INTO tempTable FROM (SELECT vXLSX.*FROM [Excel 12.0;HDR=YES;DATABASE=" & RAWDATAPATH & "].[" & WORKSHEETNAME & "$] As vXLSX)"
'DAO Execute SQL
Debug.Print mySQL
Debug.Print
tempDB.Execute mySQL, dbSeeChanges
'Do Something Else
'Close DAO Database object
tempDB.Close
Set tempDB = Nothing
myWrk.Close
Set myWrk = Nothing
'Delete temp access database if exists
If myObject.FileExists(tempDBPath) Then
'myObject.deleteFile (tempDBPath)
End If
End Sub
This should probably only be a comment, but I don't have the privileges for that.
"Compact & Repair"ing a database will help with size issues. You can use the Access visual interface to do that on a regular basis or programatically:
https://msdn.microsoft.com/en-us/library/office/bb220986(v=office.12).aspx
Compressing the file (only works on NTFS) will reduce the physical hard drive space occupied (as with ZIP or RAR) while improving speed with hard-drive access (fewer spins in the case of hard disks, and less bytes to read). You can even apply NTFS compression to a file on a network share.
Just today I further reduced the size of an Access database by simply copying all of the objects (it only consists of tables) to a new database file. So it became several times smaller even though I had already compacted it.
I said it's only a comment since it only helps, not solve every side of the problem in every way.
If you can, using append queries instead of make table ones might be worth trying too.

Inserting records in MS Access by means of macros

Good evening!
At this moment I'm learning to work in MS Access for my job purposes. I gained some understanding of the program's basics, such as creating tables or making easy forms (though not yet working ideally), and by now I've got stuck in solving the following task.
I have a database BooksDatabase, which consists of three tables: Books, Authors and AuthorsInfo. First one contains information about books (name, genre, country, release year etc.), third one is about authors (first name, last name etc.) and the second one links ever book with its author(s). The task is to import data from text file to those tables, so that it would be almost automatic. I understand how to import files to MS Access (at least, the ones of *.txt extension) and I do this into the table BooksToImport, but I have some difficulties with inserting imported data. Here is the code of my function ImportBooks(), which I execute from macros of the same name:
' Procedure which imports data about books from the table BooksToImport
Function ImportBooks()
Dim dbBooks As Database
Dim rstImBooks, rstBooks, rstAuthors, rstBALink As DAO.Recordset
Dim codeI, codeB, codeA, codeL As Variant
'initializing database
Set dbBooks = CurrentDb
Set rstImBooks = dbBooks.OpenRecordset("Query_BooksToImport",dbOpenDynaset) 'receiving data from query
'checking if the query has any records
If rstImBooks.RecordCount = 0 Then
MsgBox "There are no records for importing!", vbInformation, "Attention!"
rstImBooks.Close
Set dbBooks = Nothing
Exit Function
End If
'if it's OK, we're making a loop on query's records
rstBooks = dbBooks.OpenRecordset("Books",dbOpenDynaset)
rstAuthors = dbBooks.OpenRecordset("AuthorsInfo",dbOpenDynaset)
rstBALink = dbBoks.OpenRecordset("Authors",dbOpenDynaset)
rstImBooks.MoveLast
rstImBooks.MoveFirst
Do While rstImBooks.EOF = False
'checking if there is a book in out database with the same name as in imported data
codeB = DLookup("[ID]","[Books]","[BookName] = '" & rstImBooks![BookName] & "'")
If IsNull(codeB) Then
'inserting new record
With rstBooks
.AddNew
![BookName] = rstImBooks![BookName]
.Update
.Bookmark = .LastModified
codeB = ![ID]
End With
End If
'in much the same way we're treating the data about authors and making the links
rstImBooks.MoveNext
Loop
rstImBooks.Close
rstBooks.Close
rstAuthors.Close
rstBALink.Close
Set dbBooks = Nothing
End Function
I have two problems with this function:
method .AddNew for rstBooks is not working — MS Access shows me a message with error 438 ("Object doesn't support this property or method");
also I cannot assign variable rstBALink to the recordset because compiler says "Invalid use of property".
So my question is this: how should I solve these two problems? What do I do wrong that my function is not working properly?
A few issues with your code that I see. These may or may not fix your problem.
Your declarations are implicit, meaning you aren't being specific with your code about what your recordset objects are. Instead of using:
Dim rstImBooks, rstBooks, rstAuthors, rstBALink As DAO.Recordset
Try:
Dim rstImBooks As DAO.Recordset
Dim rstBooks As DAO.Recordset
Dim rstAuthors As DAO.Recordset
Dim rstBALink As DAO.Recordset
You can put them all on one line separated by commas, but you still need to declare the type for each or Access will assume it's a variant.
Secondly, recordset objects need to be created using the Set keyword, not by using an = alone.
This was done correctly in the top portion of your code, but is incorrect here:
rstBooks = dbBooks.OpenRecordset("Books",dbOpenDynaset)
rstAuthors = dbBooks.OpenRecordset("AuthorsInfo",dbOpenDynaset)
rstBALink = dbBoks.OpenRecordset("Authors",dbOpenDynaset)
Should be:
Set rstBooks = dbBooks.OpenRecordset("Books",dbOpenDynaset)
Set rstAuthors = dbBooks.OpenRecordset("AuthorsInfo",dbOpenDynaset)
Set rstBALink = dbBooks.OpenRecordset("Authors",dbOpenDynaset)
I think that will solve your issues, but I didn't review every line of your code admittedly. Let me know if you still have problems.
EDIT:
Found a typo:
rstBALink = dbBoks.OpenRecordset("Authors",dbOpenDynaset)
Should be:
Set rstBALink = dbBooks.OpenRecordset("Authors",dbOpenDynaset)
(missed an 'o' in dbBooks)

"User-defined type not defined" for Excel Range Using Late Binding In Access 2003

I am trying to write a VBA script which imports all of the Excel files in a folder into a table in Access 2003, first checking if they have been imported or not. That part is fine. The issue I run into is clearing out some of the formulas that don't get used on the spreadsheet which causes difficulty when Access tries to import the range. when running the code as-is, I get an error "User-defined type not defined".
I am using late binding since I am developing for a site that uses multiple versions of Office and therfore can't reference the same library using early binding. The problem code is below:
Private Sub Command2_Click()
'Declare Variables
Dim xlApp As Object
Dim xlBook As Object
Dim LSQL As String
Dim SkippedCounter As Integer
Dim ImportedCounter As Integer
Dim BUN As Long
Dim SubmitDate As Date
Dim LSQL2 As String
Dim LSQL3 As String
'Start counters for final notice
SkippedCounter = 0
ImportedCounter = 0
Dim myDir As String, fn As String
'Set directory for importing files
myDir = "U:\Five Star\Operations\restore\Surveys\My InnerView - 2010\Action plans\Action plans - input for DB\"
'Function for selecting files in folder
fn = Dir(myDir & "*.xls")
'Determine if there are files in side the folder
If fn = "" Then
MsgBox "Folder is Empty!"
Else
'Begin cycling through files in the folder
Do While fn <> ""
'Create new Excel Object
Set xlApp = CreateObject("Excel.Application")
'Make it appear on the screen while importing
xlApp.Visible = True
'Open the workbook at hand
Set xlBook = xlApp.Workbooks.Open(myDir & fn)
'Check to see if it has been imported already
If xlBook.Sheets("Action plan form").Range("A1").Value = "Imported" Then
'If it has been imported, add 1 to the counter, close the file and close the instance of Excel
SkippedCounter = SkippedCounter + 1
xlBook.Close
xlApp.Quit
Set xlBook = Nothing
Set xlApp = Nothing
Else
'Otherwise, unprotect the worksheet
xlBook.UnProtect Password:="2010"
Dim c As Range
'Unhide worksheet needed and clean it up
xlBook.Sheets("Action plan DB data").Visible = True
xlBook.Sheets("Action plan DB data").Range("B10:O10").ClearFormats
xlBook.Sheets("Action plan DB data").Range("N11:N84").ClearFormats
For Each c In xlBook.Sheets("Action plan DB data").Range("DB_import")
If c.Value = "" Or c.Value = 0 Then c.Clear
Next c
...
The rest of the code should run fine, it jsut has an issue with the declaration of "range" and looping through it. Thanks for your help!
Remove As Range from Dim c As Range and that will make c into an object. That way when it gets late-bound to a range you won't have any issues.

Import huge 550000+ row CSV file into Access

I have a CSV file with 550,000+ rows.
I need to import this data into Access, but when I try it throws an error that the file is too large (1.7GB).
Can you recommend a way to get this file into Access?
Try linking instead of importing ("get external data" -> "link table" in 2003), that leaves the data in the CSV-file and reads from the file directly and in-place. It doesn't limit size (at least not anywhere near 1.7 GB). It may limit some of your read/update operations, but it will at least get you started.
I'd either try the CSV ODBC connector, or otherwise import it first in a less limited database (MySQL, SQL Server) and import it from there.
It seems that some versions of access have a hard 2GB limit on MDB files so you might get into trouble with that anyway.
Good luck.
You can also use an ETL tool. Kettle is an open source one (http://kettle.pentaho.org/) and really quite easy to use. To import a file into a database requires a single transformation with 2 steps: CSV Text Input and Table Output.
why do you using access for huge files ? use sqlexpress or firebird instead
I remember that Access has some size limitation around 2 Go. Going to free SQLExpress (limited to 4 Go) or free MySQL (no size limitation) could be easier.
Another option would be to do away with the standard import functions and write your own. I have done this one time before when some specific logic needed to be applied to the data before import. The basic structure is……
Open then file
Get the first line
Loop through until the end of the line
If we find a comma then move onto the next field
Put record into database
Get the next line repeat etc
I wrapped it up into a transaction that committed every 100 rows as I found that improved performance in my case but it would depend on your data if that helped.
However I would say that linking the data as others have said is the best solution, this is just an option if you absolutely have to have the data in access
Access creates a lot of overhead so even relatively small data sets can bloat the file to 2GB, and then it will shut down. Here are a couple of straightforward ways of doing the import. I didn't test this on huge files, but these concepts will definitely work on regular files.
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
For really large files, you can try something like this . . .
INSERT INTO [Table] (Column1, Column2)
SELECT *
FROM [Excel 12.0 Xml;HDR=No;Database=C:\your_path\excel.xlsx].[SHEET1$];
OR
SELECT * INTO [NewTable]
FROM [Excel 12.0 Xml;HDR=No;Database=C:\your_path\excel.xlsx].[SHEET1$];