Categorised Menu List

Import Data from Ms.Excel file

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 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.

IMPORTS DATA FROM EXCEL FILE

INTO EXISTING ACCESS DATABASE TABLE

Private Sub cmdImport_Click()
On Error GoTo errHandler
    Dim dlgFO As FileDialog
    Dim intFileCount As Integer, i As Integer, rtn 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
    Dim sqlDataDelete As String

    sqlDataDelete = "Delete * from MonthlyImport"

    strUserName = Environ("username")
    strCompName = Environ("computername")
    
    Set dlgFO = Application.FileDialog(msoFileDialogOpen)
    Set fSo = New Scripting.FileSystemObject
    
    intFileCount = 0
    With dlgFO
        .Title = "Select File..."
        .Filters.Add "Excel Files Only", "*.xls", 1
        .FilterIndex = 1
        .AllowMultiSelect = True
        .InitialView = msoFileDialogViewDetails
        If .Show = False Then Exit Sub
        intFileCount = .SelectedItems.Count
    End With

    rtn = MsgBox("This operation will delete the previously existing data and replace with the latest selection" & vbCrLf & _
    "Please confirm if you want to continue...", vbQuestion + vbYesNo + vbDefaultButton2, "Delete Previous Months Data...")
    If rtn = vbYes Then

'~~~~~~~~~~~~~~~~~~~~~~~ to delete previously existing data ~~~~~~~~~~~~~~~~~~
        DoCmd.SetWarnings False
            DoCmd.RunSQL sqlDataDelete
        DoCmd.SetWarnings True
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

        intImpFiles = 0
        ReDim selFilesPath(intFileCount)
        With dlgFO
            If intFileCount > 0 Then

                For i = 1 To intFileCount
                    selFilesPath(i) = .SelectedItems(i)
                    strCurrentfile = .SelectedItems(i)
                    filename = "MonthlyImport"
                    DoCmd.Hourglass True
                    DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel8, filename, selFilesPath(i), True
                    intImpFiles = intImpFiles + 1
                Next
            Else
                Exit Sub
            End If
        End With
    Else
        Exit Sub
    End If
    
errHandler:
    Select Case Err.Number
        Case 0
            'Me.lblStatus.Caption = "Process Completed... Succesfully - Imported Database Name: Monthly Imports"
            
            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...