Frothingslosh
Premier Pale Stale Ale
- Local time
- Today, 14:39
- Joined
- Oct 17, 2012
- Messages
- 3,276
First off, if you're just going to pull a contiguous range of data in and aren't worried about validating the sheet OR the data, then just use the TransferSpreadsheet method. It's much faster, and honestly, easier to use.
That said, this is the module I built to handle the procedure when TransferSpreadsheet won't cut it. It is somewhat complex, but it was built to handle the following criteria:
I generally set up a driver that will run a routine that has the user pick the file with the Open File dialog, then verifies the file name and extension are correct, then it finally calls the verification and import functions in sequence, but it doesn't HAVE to be done this way. In the attached file, I have included a database with:
Just open a module, and in the immediate window type "Call testimport".
Here is the code for the testing. Make sure that your test data is stored at C:\TestData.xlsx - if you saved it somewhere else, then you'll need to modify the code with the correct location.
The actual import module is rather longer, consisting of a validation function, an import function, a number of data cleaning functions, and a specific lookup function. That said, here's its code:
And yes, this behemoth can be trimmed down a LOT if your columns will always be in the same location on the spreadsheet, you only have one spreadsheet you would ever import into the database, the imported data are the only fields in the destination table, etc. I will probably post trimmed versions of the code for each of these situations later.
Yes, this thing took a while to type up, but it's saving a ton of time now that I don't have to create a separate validation and import routine for every spreadsheet getting imported into every application my bosses have me build. I just slap in this module and the two tables, fill in the spreadsheet and column info, and I'm done with setting up the imports.
Oh, and if you actually (heaven forbid) use my system, don't forget to clear out the Columns and Spreadsheet tables first.
That said, this is the module I built to handle the procedure when TransferSpreadsheet won't cut it. It is somewhat complex, but it was built to handle the following criteria:
- The database requires import of multiple types of spreadsheets (Ex: Consents, Clinics, and Status).
- The needed columns could appear in any order.
- Not all lines may contain actual data.
- The data must be cleaned as it is imported.
- There are more columns in the destination table than there are being imported.
I generally set up a driver that will run a routine that has the user pick the file with the Open File dialog, then verifies the file name and extension are correct, then it finally calls the verification and import functions in sequence, but it doesn't HAVE to be done this way. In the attached file, I have included a database with:
- The import code
- The tables that drive the import procedure
- A testing module
- A test table
- A spreadsheet with test data
Just open a module, and in the immediate window type "Call testimport".
Here is the code for the testing. Make sure that your test data is stored at C:\TestData.xlsx - if you saved it somewhere else, then you'll need to modify the code with the correct location.
Code:
Option Compare Database
Option Explicit
Public Sub TestImport()
Dim xlb As Excel.Workbook
Dim xls As Excel.Worksheet
Dim Validated As Integer
Dim Imported As Boolean
On Error GoTo test_err
Set xlb = Excel.Application.Workbooks.Open("C:\TestData.xlsx")
Set xls = xlb.Sheets(1)
Validated = VerifyHeaders(xls, 1)
If Validated <> 3 Then
MsgBox "Validation Error!"
Else
Imported = ImportSpreadsheet(xls, 1)
If Imported Then
MsgBox "Import Successful"
Else
MsgBox "Import NOT Successful"
End If
End If
test_exit:
If Not xls Is Nothing Then Set xls = Nothing
If Not xlb Is Nothing Then
xlb.Close
Set xlb = Nothing
End If
Exit Sub
test_err:
MsgBox "Error " & Err.Number & ": " & Err.Description
Resume test_exit
End SubThe actual import module is rather longer, consisting of a validation function, an import function, a number of data cleaning functions, and a specific lookup function. That said, here's its code:
Code:
Option Compare Database
Option Explicit
Option Base 0
' ************************************************************
' This module requires a table named dbo_tblColumns in the back end with the following fields:
' SSID PK (Long Int - ID of the spreadsheet being checked)
' ColumnRef PK (Int - Column reference in the spreadsheet - used to generate elements for conHeaderCols)
' ColumnHeader (Txt - Column header as expected in the spreadsheet)
' BoundField (Txt - Name of the field this column will append to.
' A second table (dbo_tblSpreadsheets) is required with the following:
' SSID PK (Autonumber - Spreadsheet ID number)
' SSName (Text - Name of the spreadsheet in general terms (Clinics, Consents, etc)
' AppendTo (Text - Name of the table to which the spreadsheet will be appended)
' CheckColumn (Text - Header of a column that will ALWAYS have data in a good record.)
' HeaderRow (Long - Which row contains the headers.)
' *Note - if data is going to more than one table, it must be imported first to an
' raw data import table, THEN split.
' ************************************************************
'Column name stored when verification fails to find a specific header
Public gstrColumn As String
'Array used to track which columns contain which data.
Public gavarHeaderCols() As Variant
Public Function VerifyHeaders(ByRef xls As Worksheet, _
ByVal intSSID As Integer) As Integer
' ************************************************************
' Created by : Scott L Prince
' Parameters : Referenced spreadsheeet
' Result : Integer (0 = Misc Error, 1 = Empty dbo_tblColums, 2 = Header Mismatch, 3 = Okay)
' Date : 5/17/13
' Remarks : This routine reads the column headers and verifies the headers against values in dbo_tblColumns.
' *IMPORTANT - EXCEL LIBRARY REFERENCE 12.0 OR HIGHER MUST BE ACTIVE TO USE THIS PROCEDURE*
' Changes : (5/21/13) Modified to search for the columns that match the provided header names and determine
' the column number from that. It is to be used with a dynamic global array 'gavarHeaderCols'.
' (6/19/13) Rewritten to allow selection of spreadsheet type, and therefore, headers to be checked.
' ************************************************************
On Error GoTo VerifyHeaders_Err
Dim strProcName As String 'Procedure name
Dim strSQL As String 'SQL string
Dim dbsCurrent As DAO.Database 'Current database
Dim rstColumns As DAO.Recordset 'Recordset used to drive the search
Dim intColumnCount As Integer 'Counter used while searching column headers.
Dim blnHeaderFound As Boolean 'Flag used to track if a header is found before finding an empty cell.
Dim strTempHeader As String 'The header of the current column in the spreadsheet being searched.
Dim intColumns As Integer 'The number of columns to be imported.
Dim lngHeaderRow As Long 'The row on the spreadsheet which contains the header.
Dim intLastColumn As Integer 'The last column used on this spreadsheet.
'Set defaults.
strProcName = "VerifyHeaders"
VerifyHeaders = 0
intLastColumn = xls.UsedRange.Columns.Count
lngHeaderRow = DLookup("[HeaderRow]", "dbo_tblSpreadsheets", "[SSID] = " & intSSID)
'Create SQL string for upcoming search.
strSQL = "SELECT dbo_tblColumns.* FROM dbo_tblColumns WHERE dbo_tblColumns.SSID = " & intSSID & " ORDER BY dbo_tblColumns.ColumnRef;"
'Open a recordset based on dbo_tblColumns to get needed data for searching the designated worksheet.
Set dbsCurrent = CurrentDb
Set rstColumns = dbsCurrent.OpenRecordset(strSQL, dbOpenSnapshot)
With rstColumns
'Make sure recordset is not empty. If it is, then return 1 and exit.
If .BOF And .EOF Then
'Recordset is empty. Return code for empty recordset.
VerifyHeaders = 1
Else
'tblColumns is not empty, so get the column count.
.MoveLast
intColumns = .RecordCount
'Redim gavarHeaderCols to match the current column count.
ReDim gavarHeaderCols(intColumns - 1)
'Move back to the beginning of the recordset.
.MoveFirst
'Search the column headers on the spreadsheet for each of the required headers from the recordset, in order.
Do Until .EOF
blnHeaderFound = False 'Set to FALSE for each header.
'Cycle through each column until we find the correct header or an empty cell.
For intColumnCount = 1 To intLastColumn
'Determine the header for the current column.
strTempHeader = Trim(CStr(Nz(xls.Cells(lngHeaderRow, intColumnCount).Value, "")))
'Compare against the value we're searching for.
If strTempHeader = .Fields("ColumnHeader") Then
'Match found. Assign the current column to the matching field in gavarHeaderCols,
'set blnHeaderFound to True, and exit the loop.
gavarHeaderCols(.Fields("ColumnRef")) = intColumnCount
blnHeaderFound = True
Exit For
End If
Next intColumnCount
'Determine if a matching header was found.
If blnHeaderFound Then
'Match found, so loop to the next record.
.MoveNext
Else
'No match found. Save the missing column header to gstrColumn and exit the loop.
gstrColumn = .Fields("ColumnHeader")
Exit Do
End If
Loop
'If EOF, then all headers matched. If not EOF, then there was a mismatch.
If .EOF Then
VerifyHeaders = 3 'Return code for header okay.
Else
VerifyHeaders = 2 'Return code for header mismatch.
End If
End If
End With
VerifyHeaders_Exit:
If Not rstColumns Is Nothing Then
rstColumns.Close
Set rstColumns = Nothing
Set dbsCurrent = Nothing
End If
Exit Function
VerifyHeaders_Err:
MsgBox "Error occurred" & vbCrLf & vbCrLf & _
"In Function:" & vbTab & strProcName & vbCrLf & _
"Err Number: " & vbTab & Err.Number & vbCrLf & _
"Description: " & vbTab & Err.Description, vbCritical, _
"Error in " & Chr$(34) & strProcName & Chr$(34)
Resume VerifyHeaders_Exit
End Function
Public Function ImportSpreadsheet(ByRef objImport As Worksheet, _
ByVal intSSID As Integer) As Boolean
' ************************************************************
' Created by : slp
' Parameters : Worksheet to be imported
' Spreadsheet type to be imported
' ColumnRef of the primary field (one which will ALWAYS have data in a valid record)
' Result : Boolean
' Date : 6-4-13
' Remarks : Imports the provided worksheet into the designated table.
' *** THIS ROUTINE REQUIRES THE USE OF THE 12.0 OR HIGHER EXCEL REFERENCE LIBRARY ***
' Changes :
' ************************************************************
On Error GoTo ImportSpreadsheet_Err
Dim strProcName As String 'Procedure name
Dim lngMaxRow As Long 'Number of rows in the spreadsheet
Dim lngRow As Long 'Loop counter
Dim objWorkspace As DAO.Workspace 'Current workspace. Used to allow transaction.
Dim rstImport As DAO.Recordset 'Recordset representing table to be appended to.
Dim fld As Field 'Current field being updated
Dim intOrdinal As Integer 'Field's ordinal - will match the array element
Dim bolTransaction As Boolean 'True if a transaction is in progress, false otherwise.
Dim strTemp As String 'Used to hold each value in turn while being trimmed (if necessary)
Dim dteValue As Date 'strTemp converted to a date.
Dim varPhone As Variant 'Result of funConvertPhone function run on strTemp.
Dim lngLoop As Long 'Loop counter
Dim strDestTable As String 'Table into which data will be imported.
Dim lngFirstRow As Long 'First row with data - always the first after the header row.
Dim intCheck As Integer 'The ColumnRef of a column that contains data in all valid records.
Dim test As Variant
'Defaults
strProcName = "ImportSpreadsheet"
ImportSpreadsheet = False
Set objWorkspace = DBEngine.Workspaces(0)
bolTransaction = False
lngLoop = 1
strDestTable = DLookup("[AppendTo]", "dbo_tblSpreadsheets", "[SSID] = " & intSSID)
lngFirstRow = DLookup("[HeaderRow]", "dbo_tblSpreadsheets", "[SSID] = " & intSSID) + 1
intCheck = DLookup("[ColumnRef]", "dbo_tblColumns", "[ColumnHeader] = '" & _
DLookup("[CheckColumn]", "dbo_tblSpreadsheets", "[SSID] = " & intSSID) & "'")
'Open the table to be appended as a recordset.
Set rstImport = CurrentDb().OpenRecordset(strDestTable)
'Determine the number of rows that will be entered.
lngMaxRow = objImport.UsedRange.Rows.Count
'Create a status meter.
SysCmd acSysCmdInitMeter, "Importing data...", lngMaxRow
DoCmd.Hourglass True
'Start the transaction
objWorkspace.BeginTrans
bolTransaction = True
'Cycle through each row and import each line.
For lngRow = lngFirstRow To lngMaxRow
'Only enter rows where the column indicated by intCheck isn't blank.
If Trim(CStr(Nz(objImport.Cells(lngRow, gavarHeaderCols(intCheck)), ""))) <> "" Then
rstImport.AddNew 'Add new record
'For each field in sequence, import the matching column from gaintHeaderCols
For Each fld In rstImport.Fields
intOrdinal = GetColumnRef(fld.Name) 'Determine the correct column to pull from
If intOrdinal <> -1 Then 'The column exists in tblColumns
strTemp = Trim(CStr(Nz(objImport.Cells(lngRow, gavarHeaderCols(intOrdinal)), ""))) 'Import the appropriate value
'Clean the data according to the table settings.
Select Case fld.Type
Case dbBoolean
'Convert strTemp to True or False.
fld.Value = ConvertYN(strTemp)
Case dbCurrency
'Convert strTemp to currency.
fld.Value = ConvertToCurr(strTemp)
Case dbDate
'Convert strTemp to a date.
On Error Resume Next
dteValue = CDate(strTemp)
On Error GoTo ImportSpreadsheet_Err
If Not IsNull(dteValue) Then fld.Value = dteValue
Case dbDouble, dbByte, dbDecimal, dbInteger, dbLong, dbSingle
'Convert strTemp to a double.
fld.Value = ConvNum(strTemp, fld.Type, fld.Properties("DecimalPlaces").Value)
Case dbText
'Truncate strTemp to the field size.
fld.Value = Left(strTemp, fld.Size)
End Select
End If
Next
rstImport.Update 'Update the record
End If
lngLoop = lngLoop + 1
SysCmd acSysCmdUpdateMeter, lngLoop
Next
'All data has been imported. Commit the transaction and close out.
objWorkspace.CommitTrans
bolTransaction = False
ImportSpreadsheet = True
ImportSpreadsheet_Exit:
SysCmd acSysCmdRemoveMeter
DoCmd.Hourglass False
If Not objWorkspace Is Nothing Then 'Workspace is still defined.
If bolTransaction Then objWorkspace.Rollback 'If the transaction hasn't been committed, then roll it back.
Set objWorkspace = Nothing
End If
If Not rstImport Is Nothing Then 'Recordset is still defined.
rstImport.Close
Set rstImport = Nothing
End If
Exit Function
ImportSpreadsheet_Err:
MsgBox "Error occurred" & vbCrLf & vbCrLf & _
"In Function:" & vbTab & strProcName & vbCrLf & _
"Err Number: " & vbTab & Err.Number & vbCrLf & _
"Description: " & vbTab & Err.Description, vbCritical, _
"Error in " & Chr$(34) & strProcName & Chr$(34)
Resume ImportSpreadsheet_Exit
End Function
Function ConvertYN(ByVal varValue As Variant) As Boolean
' ************************************************************
' Created by : slp
' Parameters : Value to be converted
' Result : Boolean
' Date : 4-27-13
' Remarks : This routine converts 'Y' or 'Yes' or 'True' to True, anything else to False
' Changes :
' ************************************************************
Dim varValue1 As Variant
Dim strProcName As String
On Error GoTo ConvertYN_Err
strProcName = "ConvertYN"
Select Case varValue
Case Null
ConvertYN = False
Exit Function
Case ""
ConvertYN = False
Exit Function
Case True
ConvertYN = True
Exit Function
Case False
ConvertYN = False
Exit Function
Case Else
varValue1 = CStr(UCase(varValue))
Select Case varValue1
Case "Y"
ConvertYN = True
Exit Function
Case "YES"
ConvertYN = True
Exit Function
Case "TRUE"
ConvertYN = True
Exit Function
Case Else
ConvertYN = False
End Select
End Select
ConvertYN_Exit:
Exit Function
ConvertYN_Err:
MsgBox "Error occurred" & vbCrLf & vbCrLf & _
"In Function:" & vbTab & strProcName & vbCrLf & _
"Err Number: " & vbTab & Err.Number & vbCrLf & _
"Description: " & vbTab & Err.Description, vbCritical, _
"Error in " & Chr$(34) & strProcName & Chr$(34)
Resume ConvertYN_Exit
End Function
Function ConvertToCurr(ByVal varAmount As Variant) As Currency
' ************************************************************
' Created by : slp
' Parameters : value to be checked
' Result : Currency
' Date : 4-25-13
' Remarks : This routine converts non-numeric cell values to $0.00
' Returns either the numeric value or $0.00.
' Changes :
' ************************************************************
Dim strProcName As String
On Error GoTo ConvertToCurr_Err
strProcName = "ConvertToCurr"
'If the value of varAmount is anything other than a number, set it to 0.
If IsNull(varAmount) Or varAmount = "" Or Not IsNumeric(varAmount) Then varAmount = 0
'Convert varAmount to the Currency data type.
ConvertToCurr = CCur(varAmount)
ConvertToCurr_Exit:
Exit Function
ConvertToCurr_Err:
MsgBox "Error occurred" & vbCrLf & vbCrLf & _
"In Function:" & vbTab & strProcName & vbCrLf & _
"Err Number: " & vbTab & Err.Number & vbCrLf & _
"Description: " & vbTab & Err.Description, vbCritical, _
"Error in " & Chr$(34) & strProcName & Chr$(34)
Resume ConvertToCurr_Exit
End Function
Function ConvNum(ByVal varInput As Variant, _
ByVal varType As Variant, _
Optional ByVal bytPlaces As Byte = 0) As Variant
' ************************************************************
' Created by : slp
' Parameters : Value to be converted
' Valid numerical data type.
' Result : Numeric type as indicated by strType
' Date : 4-27-13
' Remarks : This routine converts the supplied value to a number.
' Non-numeric values become 0
' Changes :
' ************************************************************
Dim strProcName As String
Dim varTempVal As Variant
On Error GoTo ConvNum_Err
strProcName = "ConvNum"
'If imported value is a null, empty string, or non-numeric value, this function returns a 0.
If Nz(varInput, "") = "" Or Not IsNumeric(varInput) Then
varTempVal = 0
Else
varTempVal = varInput
End If
'Convert to the selected numerical data type.
Select Case varType
Case dbByte
ConvNum = CByte(varTempVal)
Case dbDouble
ConvNum = Round(CDbl(varTempVal) + 0.0000000001, bytPlaces)
Case dbDecimal
ConvNum = Round(CDec(varTempVal) + 0.0000000001, bytPlaces)
Case dbInteger
ConvNum = CInt(varTempVal + 0.0000000001)
Case dbLong
ConvNum = CLng(varTempVal + 0.0000000001)
Case dbSingle
ConvNum = Round(CSng(varTempVal) + 0.0000000001, bytPlaces)
Case Else
End Select
ConvNum_Exit:
Exit Function
ConvNum_Err:
MsgBox "Error occurred" & vbCrLf & vbCrLf & _
"In Function:" & vbTab & strProcName & vbCrLf & _
"Err Number: " & vbTab & Err.Number & vbCrLf & _
"Description: " & vbTab & Err.Description, vbCritical, _
"Error in " & Chr$(34) & strProcName & Chr$(34)
Resume ConvNum_Exit
End Function
Private Function GetColumnRef(ByVal strFieldName) As Integer
Dim strProcName As String
Dim intLocation As Integer
On Error GoTo GetColumnRef_Err
strProcName = "GetColumnRef"
intLocation = DLookup("[ColumnRef]", "dbo_tblColumns", "[BoundField] = '" & strFieldName & "'")
GetColumnRef = intLocation
GetColumnRef_Exit:
Exit Function
GetColumnRef_Err:
Select Case Err.Number
Case 94
'Invalid use of Null - no matching ColumnRef
intLocation = -1
Resume Next
Case Else
MsgBox "Error occurred" & vbCrLf & vbCrLf & _
"In Function:" & vbTab & strProcName & vbCrLf & _
"Err Number: " & vbTab & Err.Number & vbCrLf & _
"Description: " & vbTab & Err.Description, vbCritical, _
"Error in " & Chr$(34) & strProcName & Chr$(34)
Resume GetColumnRef_Exit
End Select
End FunctionAnd yes, this behemoth can be trimmed down a LOT if your columns will always be in the same location on the spreadsheet, you only have one spreadsheet you would ever import into the database, the imported data are the only fields in the destination table, etc. I will probably post trimmed versions of the code for each of these situations later.
Yes, this thing took a while to type up, but it's saving a ton of time now that I don't have to create a separate validation and import routine for every spreadsheet getting imported into every application my bosses have me build. I just slap in this module and the two tables, fill in the spreadsheet and column info, and I'm done with setting up the imports.
Oh, and if you actually (heaven forbid) use my system, don't forget to clear out the Columns and Spreadsheet tables first.
But i have a problem when import to tables. 
