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