'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
