In the previous post, we gave you some code to import from Excel into an existing table. That code is absolutely fine for most circumstances but we thought you might like to improve on it a little…
In this post, we add the ability to select your Excel file using a File Picker and a function that creates the table if it doesn’t already exist!
It is worth noting again that the success of an import from Excel is largely due to the preparation you give the Excel file.
The Code
Create a module called mod_Functions and add this code:
Option Compare Database
Option Explicit
Public Function getFilePath() As String
'The function will open up msoFileDialogFilePicker
'(a standard windows file picker) that will enable
'the user to pick a file from their system
On Error GoTo ErrorHandler
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False
.Show
getFilePath = .SelectedItems(1)
End With
ExitFunction:
Exit Function
ErrorHandler:
getFilePath = ""
Resume ExitFunction
End Function
Public Function getFolderPath() As String
'The function will open up msoFileDialogFolderPicker
'(a standard windows file picker) that will enable
'the user to pick a folder from their system
On Error GoTo ErrorHandler
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
getFolderPath = .SelectedItems(1)
End With
ExitFunction:
Exit Function
ErrorHandler:
getFolderPath = ""
Resume ExitFunction
End Function
Public Function getFileName(filePath As String) As String
'This function takes a full path to a file and returns just the
'name portion.
'e.g. C:\users\Robert\excel_file.xlsx will become excel_file.xlsx
On Error GoTo ErrorHandler
Dim posOfSlash As Integer
Dim lenOfString As Integer
Dim remChars As Integer
posOfSlash = InStrRev(filePath, "\")
lenOfString = Len(filePath)
remChars = lenOfString - posOfSlash
getFileName = Right(filePath, remChars)
ExitFunction:
Exit Function
ErrorHandler:
getFileName = ""
Resume ExitFunction
End Function
Public Function MakeTable(strTableName As String, strFieldNames() _
As String) As Boolean
'This function takes a table name and an array of columns and
'creates a table with the relevant field names
On Error GoTo ErrorHandler
Dim strSQL As String
Dim element As Variant
strSQL = "CREATE TABLE " & strTableName & " ("
For Each element In strFieldNames
'Debug.Print element
strSQL = strSQL & element & " TEXT, "
Next
strSQL = Left(strSQL, Len(strSQL) - 2) & ")"
CurrentDb.Execute strSQL, dbFailOnError
MakeTable = True
ExitFunction:
Exit Function
ErrorHandler:
MakeTable = False
Resume ExitFunction
End Function
Now, create a module called mod_Excel_Importing and add this code:
Option Compare Database
Option Explicit
Public Sub GetData()
On Error GoTo ErrorHandler
Dim oExcel As Excel.Application
Dim oWB As Workbook
Dim oWS As Worksheet
Dim strExcelFilePath As String
Dim strExcelFileName As String
Dim db As dao.Database
Dim rs As dao.Recordset
Dim i As Integer
Dim j As Integer
Dim lColumn As Long
Dim lRow As Long
Dim strFieldNames() As String
Dim strTableName As String
'Select Excel file to import from
'This code will open up a standard Windows file picker
MsgBox "Please select the Excel Workbook to import from"
strExcelFilePath = getFilePath()
strExcelFileName = getFileName(strExcelFilePath)
'Starts hourglass so user knows that the application is busy
DoCmd.Hourglass True
'Starts Excel App in memory
Set oExcel = New Excel.Application
Set oWB = oExcel.Workbooks.Open(strExcelFilePath)
'Here we ask for the table name that we will be using
strTableName = InputBox("Please provide the table name")
'----------------------------------------------------------------
'We check whether the supplied table name is the name of a table
'that already exists. If it doesn't exist, we create it.
'----------------------------------------------------------------
If IsNull(DLookup("Name", "MSysObjects", "Name='" & _
strTableName & "'")) Then
'In order to create the table we need to know how many
'columns we require and the names of those columns
'For this we need to activate the Excel sheet and count
'the columns and retrieve their names
With oWB
.Activate
'Function to return number of columns
lColumn = _
.Worksheets(1).Cells(1, Columns.Count).End(xlToLeft).Column
'We have an array called strFieldNames that we want
'to store the column names
ReDim strFieldNames(lColumn - 1)
'add names of columns to strFieldNames by
'looping through the columns in the Excel
'sheet and retrieving the names
For j = 0 To lColumn - 1
strFieldNames(j) = _
.Worksheets(1).Cells(1, j + 1).Value
Next j
End With
'We utilise the MakeTable function to create a table that
'we will be able to import into
If MakeTable(strTableName, strFieldNames) = False Then _
Err.Raise -100, , "Unable to create table."
End If
'----------------------------------------------------------
'Get data from Excel sheet
'----------------------------------------------------------
'Instantiate recordset - we will not be looping through here
'we will be using the recordset to add values as we go
Set db = CurrentDb
Set rs = db.OpenRecordset(strTableName)
With oWB
'we will need to activate the workbook to
'reference its properties
.Activate
'These two lines of code work out how many
'columns (lcolumn) and how many rows(lrow) of
'data there are to be imported in the Excel sheet
lColumn = _
.Worksheets(1).Cells(1, Columns.Count).End(xlToLeft).Column
lRow = _
.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
'add link to nested loops
'Here we will be using a nested loop
'to go to loop through the Excel sheet.
'Nested loops are necessary when looping
'through a grid of data such as a spreadsheet
'from 2nd row to last
For i = 2 To lRow
'we tell the recordset that we will
'be adding a record here
rs.AddNew
'From first column to last
For j = 0 To lColumn - 1
'Here we are saying:
'Take the value of row i and column j
'and add it to the column
'that has an index of j!!!
rs.Fields(j) = _
Nz(.Worksheets(1).Cells(i, j + 1).Value, "")
Next j
Debug.Print i
'This writes the update to the table
rs.Update
Next i
'close the recordset
rs.Close
End With
DoCmd.Hourglass False
MsgBox "Finshed"
ExitSub:
'Always remember to set your objects to nothing
'when the procedure ends
Set rs = Nothing
Set db = Nothing
Set oWB = Nothing
Set oExcel = Nothing
DoCmd.Hourglass False
Exit Sub
ErrorHandler:
MsgBox "There has been an error. " & _
"Please reload the form and start again"
Resume ExitSub
End Sub
Using VBA to retrieve data from Excel is a little tricky at first as you need to familiarise yourself with the Excel object model. There are, however, definite rewards if you persist, as using Excel as a means of transferring information between databases is a very popular option!
