Auto Import WorkSheet into a dynamic Access Table - Example

[Bruce Fox]

I needed a way to automatically import a user selected Excel spreadsheet into a new (dynamic) Access table.

I will move it to the code bank if there is no glaring error

This was what I came up with. It is fast, very fast, compared to other methods of looping past each Excel cell etc.

It also creates and formats the new Table dynamically – no matter how many columns exist in the Excel sheet.

I also needed a way to return the success of the Function, being one of three states. So I decided to return a tri-state using a Long. The calling routine can then display the status (in a StatusBar) what happened. Ie. Import Successful, User Selected Cancel (from the CommonDialog Show Open) or an unsuccessful import.

Note: It was written for VBA (as a Module).

'In a Module
Option Compare Database
Option Explicit
 
Public Function Import_SpreedSheet() As Long
Dim cnnExcel As ADODB.Connection
Dim rstExcel As ADODB.Recordset
Dim strSQLExcel As String
Dim strSQL As String
Dim strExcelToOpen As String
Dim strSheetName As String
Dim intFieldCount As Integer
Dim intIdx As Integer
Dim strColBuff As String
 
On Error GoTo Err_Handler
 
    'Obtain the Excel File to be used for the Import
    strExcelToOpen = Open_Dialog(Application.hWndAccessApp)
    If strExcelToOpen = "" Then
        Import_SpreedSheet = 1
        Exit Function 'As Cancel was pressed
    End If
 
    Set cnnExcel = New ADODB.Connection
    Set rstExcel = New ADODB.Recordset
 
    cnnExcel = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strExcelToOpen & ";Extended Properties=""Excel 8.0;HDR=No"""
    cnnExcel.Open
 
    'Capture the First Sheet name. This is used to as the Table Save Name
    strSheetName = cnnExcel.OpenSchema(adSchemaTables).Fields("TABLE_NAME").Value
 
    strSQLExcel = "SELECT * FROM [" & strSheetName & "]"
    rstExcel.Open strSQLExcel, cnnExcel
 
    If Not (rstExcel.BOF Or rstExcel.EOF) Then
 
        'Capture the number of Fields required
        intFieldCount = rstExcel.Fields.Count - 1   '0 based
 
        'Create the dynamic Fields Names base on the number of Columns
        For intIdx = 0 To intFieldCount
            If intIdx < intFieldCount Then
                strColBuff = strColBuff & rstExcel.Fields(intIdx).Name & " varchar, "
            Else
                strColBuff = strColBuff & rstExcel.Fields(intIdx).Name & " varchar"
            End If
        Next
 
        'Now we have used the 'Sheet' name, it's time to strip of the ADO parenthesis (being ' & $)
        strSheetName = Replace(Replace(strSheetName, "'", ""), "$", "")
 
        'Add a new (unique) Table
        strSQL = "CREATE TABLE [tbl" & strSheetName & "] (" & strColBuff & ")"
        CurrentProject.Connection.Execute strSQL
 
        'Now the Table has been corectly formated, add the SpreedSheet data
        DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, "tbl" & strSheetName, strExcelToOpen, False, "A:" & Chr$(64 + intFieldCount + 1)
 
    End If
 
    'Perform Housekeeping (as required)
    If rstExcel.State = adStateOpen Then
        rstExcel.Close
        Set rstExcel = Nothing
    End If
    If cnnExcel.State = adStateOpen Then
        cnnExcel.Close
        Set cnnExcel = Nothing
    End If
 
    Import_SpreedSheet = True
 
Exit Function
 
Err_Handler:
 
    If Err.Number = -2147217900 Then    'Table already exists
         MsgBox "Please change the Excel WorkSheet Name," & vbCrLf & _
         "as this becomes the Save Name of the Table.", vbOKOnly + vbInformation, "Table Already Exists!"
    Else
         MsgBox "Description: " & Err.Description & vbCrLf & _
        "Number: " & Err.Number, vbOKOnly + vbInformation, "Import Error!"
    End If
 
    'Destroy objects (as required)
    If rstExcel.State = adStateOpen Then
        rstExcel.Close
        Set rstExcel = Nothing
    End If
    If cnnExcel.State = adStateOpen Then
        cnnExcel.Close
        Set cnnExcel = Nothing
    End If
 
    Import_SpreedSheet = False
 
End Function

My calling routine:

'On my Form
    Me.sbMain.Panels(1).Text = "Importing"
 
    Select Case Import_SpreedSheet 'Call the Function, return result
        Case True   'Success
            Me.sbMain.Panels(1).Text = "Complete"
            MsgBox "Excel SpreedSheet sucessfully imported.", vbOKOnly + vbInformation, "Complete"
            Me.sbMain.Panels(1).Text = "Ready"
        Case False  'An error occured
            Me.sbMain.Panels(1).Text = "Error"
        Case 1      'Cancel was pressed
            Me.sbMain.Panels(1).Text = "Canceled"
    End Select