Import data to Access from Excel

Back in January, I promised to post a macro that imports data from Excel into Access programmatically.

(See My First Access Macro.)

It takes a given spreadsheet and imports it into a given Access file/table. The spreadsheet must have a header row, with no blank rows or columns inside the table block. You must set a reference to the appropriate Access object library (Microsoft Access x.0 Object Library).

How it works:

First it uses a simple API call to get the local username, so that the spreadsheet can be (temporarily) saved to the user's desktop. Then it checks to see if the .mdb file is already open by looking for a matching .ldb file — if an Access .mdb file is open, a .ldb file with the same name is created in the same folder to indicate that the database file is open/locked. We don't want to update a file that is already open by another user, to avoid data corruption.

The spreadsheet is saved to the user's desktop and closed for import. Then an instance of Access is started and the spreadsheet imported into the specified table. After a Msgbox is shown to confirm the import, the temp file is deleted from the desktop.

Option Explicit
' set a reference to Access Object Library before using this code

Public Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" ( _
    ByVal lpBuffer As String, _
    nSize As Long) As Long

' function to get username
Public Function Username() As String
Dim lpBuff As String * 1024
GetUserName lpBuff, Len(lpBuff)
Username = Left$(lpBuff, (InStr(1, lpBuff, vbNullChar)) - 1)
End Function

Sub ImportReportToAccess()
'
' open Access database and append ss to appropriate table
'
Application.ScreenUpdating = False

' first check if db file is locked, if so then don't run!
If Dir("C:\databasefile.ldb") = "" Then
' If a .mdb file is open, a matching .ldb file with the same name is opened in the same directory
    Dim AWName As String
    Dim UserN As String
    ' the newest report
    AWName = ActiveWorkbook.Name

    ActiveSheet.UsedRange
    UserN = Username
    Workbooks(AWName).SaveAs "C:\Documents And Settings\" & UserN & "\Desktop\" & AWName, FileFormat:=xlNormal
    Workbooks(AWName).Close
    Dim axsApp As Access.Application
    Set axsApp = New Access.Application

    With axsApp
        .OpenCurrentDatabase "C:\databasefile.mdb", True
        .DoCmd.OpenTable "table name"
        .DoCmd.TransferSpreadsheet acImport, , "table name", "C:\Documents And Settings\" & UserN & "\Desktop\" & AWName, True
        .CloseCurrentDatabase
    End With

    MsgBox "import complete"

    Kill "C:\Documents And Settings\" & UserN & "\Desktop\" & AWName

Else
    MsgBox ("Database file appears to be locked. Please try again later."), vbCritical
    Exit Sub
End If

ExitProc:
Set axsApp = Nothing
Application.ScreenUpdating = True
End Sub

Enjoy,
JP