Code:
Private Sub cmd_imp_Click()
On Error GoTo Err_cmd_imp_Click
Dim lngColumn As Integer
Dim xlx As Object, xlw As Object, xls As Object, xlc As Object
'Dim lastrow As Long
Dim rst As DAO.Recordset, MyRec As DAO.Recordset, Myext As DAO.Recordset
Dim blnEXCEL As Boolean
blnEXCEL = True
Dim strFileName As String
Dim strFileLoc As String
Dim Filepath As String
Dim StrSheetName As String
Dim f As Object
Dim varItem As Variant
Set f = Application.FileDialog(3)
f.AllowMultiSelect = True
If f.Show Then
For Each varItem In f.SelectedItems
strFileName = Dir(varItem)
strFileLoc = Left(varItem, Len(varItem) - Len(strFileName))
strFilePath = strFileLoc & strFileName
Next
End If
Dim temparray() As String
temparray = Split(strFileName, "_") ' this is to capture the date from the filename
' Establish an EXCEL application object
On Error Resume Next
Set xlx = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
Set xlx = CreateObject("Excel.Application")
blnEXCEL = True
End If
Err.Clear
On Error GoTo 0
xlx.Visible = True
DoCmd.SetWarnings False
Set xlw = xlx.Workbooks.Open(strFilePath, , True)
Set xls = xlw.Worksheets(2)
DoCmd.SetWarnings False
DoCmd.RunSQL "Delete * from B_temp;"
DoCmd.SetWarnings True
' first data value (non-header information) that contains data
Set xlc = xls.Range("A3")
Set rst = CurrentDb.OpenRecordset("B_temp") ', dbOpenDynaset, dbAppendOnly)
' write data to the recordset
If xlc.Value = " " Then
Exit Sub
Else
For i = 0 To 200
rst.AddNew
For lngColumn = 0 To rst.Fields.Count - 1
rst.Fields(lngColumn).Value = xlc.Offset(i, lngColumn).Value
Next lngColumn
rst.Fields("File_name") = strFileName
rst.Fields("Date_FileReceived") = Format(temparray(1), "##/##/####")
rst.Update
Next i
End If
rst.Close
Set xls1 = Nothing
xlw.Close False
Set xlw = Nothing
If blnEXCEL = True Then xlx.Quit
Set xlx = Nothing
Exit_cmd_imp_Click:
Exit Sub
Err_cmd_imp_Click:
MsgBox "Error No: " & Err.Number _
& vbNewLine _
& Err.Description, _
vbExclamation + vbOKOnly, _
"Error Information"
Resume Exit_cmd_imp_Click
End Sub