Difference makes the DIFFERENCE
Consulting - Quality
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.
- DoCmd.SetWarnings
- DoCmd.RunSQL
- DoCmd.Hourglass
- DoCmd.TransferSpreadsheet
- 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.
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...