Below code works fine to read Sheet1 "Facility_Details" and stops when going to Sheet2 "Bulk_Results_ReportingSheet".
Worked fine last week but I modified many things and now it stopped working. Any help is much appreciated?
Code:
Private Sub cmd_imp_Click()
On Error GoTo Err_cmd_imp_Click
Dim lngColumn As Integer 'Double
Dim xlx As Object, xlw As Object, xls As Object, xlc As Object
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
StrSheetName = Lab_Facility_Details
Next
End If
' 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
DoCmd.RunSQL "Delete * from Facility_Details_temp;"
xlx.Visible = True
DoCmd.SetWarnings False
Set xlw = xlx.Workbooks.Open(strFilePath, , True)
Set xls = xlw.Worksheets("Facility_Details") '(StrSheetName)
'If xls.Value = "Lab_Facility_Details" Then
Set MyRec = CurrentDb.OpenRecordset("Facility_Details_temp")
MyRec.AddNew
MyRec.Fields("File_name") = strFileName
MyRec.Fields("LName") = xls.cells(2, "C")
MyRec.Fields("LAddress1") = xls.cells(3, "C")
MyRec.Fields("LCity") = xls.cells(5, "C")
MyRec.Fields("LState") = xls.cells(6, "C")
MyRec.Fields("LPostalCode") = xls.cells(7, "C")
MyRec.Update
DoCmd.OpenQuery "Append_Temp_tbl_Facility_Details"
MyRec.Close
Set MyRec = Nothing
'Read sheet 2 data from A3 onwards
'Set xlw = xlx.Workbooks.Open(strFilePath, , True)
Set xls = xlw.Worksheets("Bulk_Results_ReportingSheet") ' Fails/stops at this point saying subscript out of range
DoCmd.SetWarnings False
DoCmd.RunSQL "Delete * from BulkResults_temp;"
DoCmd.SetWarnings True
Set xlc = xls.Range("A3")
Set rst = CurrentDb.OpenRecordset("BulkResults_temp") ', dbOpenDynaset, dbAppendOnly)
' write data to the recordset
If xlc.Value = " " Then
Exit Sub
Else
For i = 0 To 100
rst.AddNew
For lngColumn = 0 To rst.Fields.Count - 1
rst.Fields(lngColumn).Value = xlc.Offset(i, lngColumn).Value
' MsgBox xlc.Offset(i, lngColumn).Value
Next lngColumn
rst.Fields("File_name") = strFileName
rst.Update
'Set xlc = xlc.Offset(1, 0)
Next i
End If
' DoCmd.OpenQuery "Append_temp_res_to_tbl_res"
'Set MyRec = 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 Err.Description
MsgBox "Error No: " & Err.Number _
& vbNewLine _
& Err.Description, _
vbExclamation + vbOKOnly, _
"Error Information"
Resume Exit_cmd_imp_Click
End Sub