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

[Bruce Fox]

Here is the CommonDialog Module (addapted from AllApi.net)

Option Compare Database
Option Explicit
 
Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
 
Private Type OPENFILENAME
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    lpstrFilter As String
    lpstrCustomFilter As String
    nMaxCustFilter As Long
    nFilterIndex As Long
    lpstrFile As String
    nMaxFile As Long
    lpstrFileTitle As String
    nMaxFileTitle As Long
    lpstrInitialDir As String
    lpstrTitle As String
    flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    lpstrDefExt As String
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type
 
Public Function Open_Dialog(ByVal lngHwnd As Long) As String
    Dim OFName As OPENFILENAME
    OFName.lStructSize = Len(OFName)
    'Set the parent window
    OFName.hwndOwner = lngHwnd
    'Set the application's instance
    ''''OFName.hInstance =
    'Select a filter
    OFName.lpstrFilter = "Excel Files (*.xls)" & vbNullChar & "*.xls" & vbNullChar
    'Create a buffer for the file
    OFName.lpstrFile = Space$(254)
    'Set the maximum length of a returned file
    OFName.nMaxFile = 255
    'Create a buffer for the file title
    OFName.lpstrFileTitle = Space$(254)
    'Set the maximum length of a returned file title
    OFName.nMaxFileTitle = 255
    'Set the initial directory
    OFName.lpstrInitialDir = CurrentProject.Path
    'Set the title
    OFName.lpstrTitle = "Select an Excel WorkSheet to Import"
    'No flags
    OFName.flags = 0
 
    'Show the 'Open FileDialog
    If GetOpenFileName(OFName) Then
        Open_Dialog = Replace(Trim$(OFName.lpstrFile), Chr(0), "")
    Else
        Open_Dialog = ""
    End If
End Function

[RobDog888]

We sure do think alike. I just finished with a thread in the db forum on similar Excel mechanics.

Access and Excel

Great job on using all ADO to provide the solution. I used a combo of ADO and Excel Object Model.

[Bruce Fox]

Hi RD

It was the dynamic table that spawned this method - there was nothing that I could find that could do what I needed...

Cheers,