Categorised Menu List

Import Spreadsheet to Access

A command button cmdImport is placed in Ms.Access User form to execute.

 

The data derieved from mail:

 

Uses DoCmd method.

  1. DoCmd.SetWarnings
  2. DoCmd.RunSQL
  3. DoCmd.Hourglass 
  4. DoCmd.TransferSpreadsheet
  5. Exception handler to the end

Context: 

Daily, a user gets different types of data in excel file through a mail, the respective user needs to import that excel file into Ms.Access table and start working.  

 

How it works: 

Access contains a table to store today's work data., so, it deletes the existing data and replaces the same table with today's data.

IMPORT SPREADSHEET

INTO EXISTING ACCESS DATABASE TABLE

Private Sub cmdOK_Click()
'Dim strDB As String

strDBType = Nz(Me.cmbImportDBs.Value, "")
    If strDBType = "" Or IsEmpty(strDBType) Or IsNull(strDBType) Then
        MsgBox "You have not yet selected the type of upload from the list of entires.... Select one to continue.........!!", vbInformation + vbOKOnly, "Import database..."
        Me.cmbImportDBs.SetFocus
    Else
        Select Case strDBType
            Case "POdatabase"
                ImportXls strDBType
            Case "ExemptDatabase"
                ImportXls strDBType
            Case "PreClassDatabase"
                ImportXls strDBType
            Case "SupplierDatabase"
                ImportXls strDBType
        End Select
    End If
End Sub
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Private Sub ImportXls(strDBName As String)

On Error GoTo errHandler
    Dim dlgFO As FileDialog
    Dim intFileCount As Integer, i As Integer
    Dim selFilesPath() As Variant
    Dim filename As String, errString As String
    Dim dtStart As Date, dtEnd As Date
    Dim sqlUpdate As String, strUserName As String, strCompName As String
    Dim strUpdateDate As String, strUpdateBy As String, strUpdateOn As String
    
    strUserName = Environ("username")
    strCompName = Environ("computername")
    
    Set dlgFO = Application.FileDialog(msoFileDialogOpen)
    Set fSo = New Scripting.FileSystemObject
    
    intFileCount = 0
    With dlgFO
        .Title = "Select Files... for " & strDBName
        .Filters.Add "Excel Files Only", "*.xls", 1
        .FilterIndex = 1
        .AllowMultiSelect = True
        .InitialView = msoFileDialogViewDetails
        .Show
        intFileCount = .SelectedItems.Count
    End With
    
    intImpFiles = 0
    ReDim selFilesPath(intFileCount)
    With dlgFO
        If intFileCount > 0 Then
            Me.lblStatus.Caption = "Importing spreadsheets..."
            For i = 1 To intFileCount
                selFilesPath(i) = .SelectedItems(i)
                strCurrentfile = .SelectedItems(i)
                filename = strDBName
                DoCmd.Hourglass True
                DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel8, filename, selFilesPath(i), True
                intImpFiles = intImpFiles + 1
            Next
        Else
            Exit Sub
        End If
    End With
    
errHandler:
    Select Case Err.Number
        Case 0
            Me.lblStatus.Caption = "Process Completed... Succesfully - Imported Database Name: " & strDBName
            DoCmd.SetWarnings False
            sqlUpdate = "Insert into tblFileUpload values (#" & Now() & "#, '" & strUserName & "', '" & strCompName & "', '" & "Succesfull: " & strDBName & "')"
                DoCmd.RunSQL sqlUpdate
            DoCmd.SetWarnings True
            DoCmd.Hourglass False
            Exit Sub
        Case 3161
            MsgBox "File Name: " & UCase(dlgFO.SelectedItems(i)) & _
                " file is password protected and hence cannot be imported" & vbCrLf & vbNewLine & _
                "Unprotect THIS file and try again", vbCritical + vbOKOnly, "Import Fail..."
                
                DoCmd.SetWarnings False
                    sqlUpdate = "Insert into tblFileUpload values (#" & Now() & "#, '" & strUserName & "', '" & strCompName & "', '" & _
                    "Failure: reason - excel file password protected " & "')"
                    DoCmd.RunSQL sqlUpdate
                DoCmd.SetWarnings True

                DoCmd.Hourglass False
                Resume Next
        Case 2391
            MsgBox " The selected filename is : " & strDBName & vbCrLf & _
                "The selecetd database name is " & strDBType & vbCrLf & vbNewLine & _
                "Select appropriate excel file to match the database", vbCritical + vbOKOnly, "File Mismatch..."
                
                DoCmd.SetWarnings False
                    sqlUpdate = "Insert into tblFileUpload values (#" & Now() & "#, '" & strUserName & "', '" & strCompName & "', '" & _
                    "Failure: File Mismatch - selected " & strCurrentfile & " for " & strDBType & "')"
                    DoCmd.RunSQL sqlUpdate
                DoCmd.SetWarnings True
                
                DoCmd.Hourglass False
                Exit Sub
        Case Else
            errString = Left(Err.Number & ": " & Err.Description, 201)
            MsgBox Err.Number & " " & Err.Description & vbCrLf & vbNewLine & _
                "Please make a note of the number and its description and contact Management", vbInformation + vbOKOnly, "Import Fail"
                
                DoCmd.SetWarnings False
                    sqlUpdate = "Insert into tblFileUpload values (#" & Now() & "#, '" & strUserName & "', '" & strCompName & "', '" & _
                    "Failure: Reason - " & errString & "')"
                    DoCmd.RunSQL sqlUpdate
                DoCmd.SetWarnings True
                               
                DoCmd.Hourglass False
                Exit Sub
    End Select
    MsgBox "Import, Consolidation and Deletion of Temperory tables Completed Succesfully...!", vbInformation + vbOKOnly, "Import..."
    DoCmd.Hourglass False
End Sub

Issues you may encounter: While you copy and paste the code from here to code window, replace double quotes in code window again, as these quotes will appear as smart quotes.

 

Original Code, Company names and user names are replaced with false names.

Code file in .txt format

It is always advisable to make best use of status bar.  Application.StatusBar = "some text"

This will help end user to know that the work is in progress...