I'm getting an error message after the last loop runs in this procedure.The error is received after it cycles through the last worksheet in the excel workbook, and the line is "xl.ActiveSheet.Next.Select" (line 17 from the bottom). Can anyone give me a pointer? I've read and been told using .select is not ideal, but this is an older database I have inherited and would like to resolve this issue before improving the code.
The loop opens up an excel file and cycles through each worksheet (24 in this workbook) and imports the data to an access database. I've searched this topic but many issues seem unrelated, or much simpler to debug. I've even removed all but two worksheets and the error is still repeatable. Any help is appreciated! Thanks!
Private Sub lbl_WV_import_Click()
If gcfHandleErrors Then On Error GoTo Err_frmMe_home_lbl_WV_import
Dim xl As Object, wrkbk1 As Object
Dim pcd As String, pcd_title As String, model As String, station As String, task As String, pic As String, bom_pn As String, c1 As String, c2 As String, spec As String, sApp As String
Dim pn As String, pname As String, ts_part_name As String, ts_part_num As String, model_info As String, color As String, dest As String, tool As String, socket As String, torque As String, misc As String
Dim rev As Integer, zone As Integer, seq As Integer, mod_id As Integer, delta As Integer, st_seq As Integer, qty As Integer, i As Integer, J As Integer, ts_sec As Integer, sec As Integer, row As Integer
Dim pcd_id As LongPtr, stat_id As LongPtr, task_id As LongPtr, task_list_id As LongPtr, pn_id As LongPtr, tool_id As LongPtr, task_step_id As LongPtr
Dim pitch As Double
Set db = CurrentDb()
sApp = "Excel.Application"
If IsAppRunning(sApp) = True Then
Set xl = GetObject(, "Excel.Application")
For Each wrkbk1 In xl.Workbooks
If wrkbk1.Name = "P1_PCD.xlsm" Then
Exit For
End If
Next
strSQL = DLookup("db_loc", "tbl_ext_source") & DLookup("area", "tblArea") & "\P1_PCD.xlsm"
Set wrkbk1 = xl.Workbooks.Open(strSQL)
Else
Set xl = CreateObject("Excel.Application")
xl.Application.Visible = True
strSQL = DLookup("db_loc", "tbl_ext_source") & DLookup("area", "tblArea") & "\P1_PCD.xlsm"
Set wrkbk1 = xl.Workbooks.Open(strSQL)
End If
xl.Workbooks("P1_PCD.xlsm").Activate
xl.Sheets(1).Select
xl.Range("B1").Select
pcd_title = xl.Range("B1").Value
xl.Range("O2").Select
pitch = xl.Range("O2").Value
xl.Range("Q2").Select
pcd = "PCD-" & xl.Range("Q2").Value
xl.Range("R2").Select
rev = xl.Range("R2").Value
xl.Range("K3").Select
model = xl.Range("K3").Value
If IsNull(DLookup("model", "tblModel", "[model] = '" & model & "'")) Then
strSQL = "INSERT INTO tblModel (model) " _
& "Values ('" & model & "')"
db.Execute strSQL
lid = DMax("mod_id", "tblModel")
strSQL = "INSERT INTO " _
& "tblAudit (EditDate, RecordSource, RecordID, User, Field, BeforeValue, AfterValue) " _
& "VALUES (Now(), ""tblModel"", '" & lid & "', '" & fosUserName() & "', ""model"", ""New Record"", '" & model & "')"
db.Execute strSQL
End If
If IsNull(DLookup("pcd", "tblPCD", "pcd='" & pcd & "' AND rev=" & rev & "")) Then
mod_id = DLookup("mod_id", "tblModel", "[model] = '" & model & "'")
bom_pn = DLookup("ItemNo", "PYMAC", "LV = ""00""")
strSQL = "INSERT INTO tblPCD ( pcd, pcd_title, rev, mod_id, pitch, pre_rev, bom_pn ) " _
& "VALUES ('" & pcd & "','" & pcd_title & "', " & rev & ", " & mod_id & ", " & pitch & ", " & rev - 1 & ", '" & bom_pn & "')"
db.Execute strSQL
pcd_id = DLookup("pcd_id", "tblPCD", "pcd='" & pcd & "' AND rev=" & rev & "")
lid = DMax("pcd_id", "tblPCD")
strSQL = "INSERT INTO " _
& "tblAudit (EditDate, RecordSource, RecordID, User, Field, BeforeValue, AfterValue) " _
& "VALUES (Now(), ""tblPCD"", '" & lid & "', '" & fosUserName() & "', ""ALL"", ""New Record"", ""New PCD from excel "" & " & pcd_id & ")"
db.Execute strSQL
Call upload_pymac(pcd_id)
Set db = CurrentDb()
Else
If InputBox("This PCD already exists. Is this another section of this PCD that needs to be imported? [Y/N]") = "y" Then
Else
Exit Sub
End If
End If
pcd_id = DLookup("pcd_id", "tblPCD", "pcd='" & pcd & "' AND rev=" & rev & "")
If IsNull(DMax("seq", "tblTask", "[pcd_id] = " & pcd_id & "")) Then
seq = 1
Else
seq = DMax("seq", "tblTask", "[pcd_id] = " & pcd_id & "")
End If
For J = 1 To xl.ActiveWorkbook.Worksheets.Count
xl.Range("O3").Select
station = xl.Range("O3").Value
If IsNull(DLookup("station", "tblStation", "[station] = '" & station & "'")) Then
If IsNull(DMax("stat_id", "tblStation")) Then
sec = 1
Else
sec = DMax("stat_id", "tblStation") + 1
End If
strSQL = "INSERT INTO tblStation ( station, zone_id,sec ) " _
& "VALUES ('" & station & "',1," & sec & ")"
db.Execute strSQL
lid = DMax("stat_id", "tblStation")
strSQL = "INSERT INTO " _
& "tblAudit (EditDate, RecordSource, RecordID, User, Field, BeforeValue, AfterValue) " _
& "VALUES (Now(), ""tblStation"", '" & lid & "', '" & fosUserName() & "', ""ALL"", ""New Records"", ""New record for PCD "" & " & pcd_id & ")"
db.Execute strSQL
End If
stat_id = DLookup("stat_id", "tblStation", "[station] = '" & station & "'")
st_seq = 1
c1 = "C6"
xl.Range(c1).Select
Do Until xl.CountA(xl.ActiveCell) = 0
xl.Range(c1).Select
task = xl.ActiveCell.Value
If Len(task) > 250 Then
task = Left(task, 255)
End If
If IsNull(DLookup("task_txt", "tblTask_txt", "[task_txt] = '" & task & "'")) Then
strSQL = "INSERT INTO tblTask_txt ( task_txt ) " _
& "VALUES ('" & task & "')"
db.Execute strSQL
lid = DMax("task_list_id", "tblTask_txt")
strSQL = "INSERT INTO " _
& "tblAudit (EditDate, RecordSource, RecordID, User, Field, BeforeValue, AfterValue) " _
& "VALUES (Now(), ""tblTask_txt"", '" & lid & "', '" & fosUserName() & "', ""task_txt"", ""New Record"", '" & task & "')"
db.Execute strSQL
End If
task_list_id = DLookup("task_list_id", "tblTask_txt", "[task_txt] = '" & task & "'")
xl.ActiveCell.Offset(0, 4).Select
If xl.ActiveCell.Value = "Q" Then
delta = 1
ElseIf xl.ActiveCell.Value = "C" Then
delta = 2
ElseIf xl.ActiveCell.Value = "CTQ" Then
delta = 3
ElseIf xl.ActiveCell.Value = "R" Then
delta = 4
Else
delta = 0
End If
xl.ActiveCell.Offset(0, 1).Select
spec = Replace(xl.ActiveCell.Value, "'", "''")
If Len(spec) > 250 Then
spec = Left(spec, 255)
End If
strSQL = "INSERT INTO tblTask ( pcd_id, seq, stat_id, task_list_id, st_seq, spec_inst ) " _
& "Values (" & pcd_id & ", " & seq & ", " & stat_id & ", " & task_list_id & "," & st_seq & ", '" & spec & "')"
db.Execute strSQL
task_id = DMax("task_id", "tblTask")
lid = DMax("task_id", "tblTask")
strSQL = "INSERT INTO " _
& "tblAudit (EditDate, RecordSource, RecordID, User, Field, BeforeValue, AfterValue) " _
& "VALUES (Now(), ""tblTask_txt"", '" & lid & "', '" & fosUserName() & "', ""ALL"", ""New Record"", ""New record for PCD "" & " & pcd_id & ")"
db.Execute strSQL
row = xl.ActiveCell.row()
c2 = "E" & row
xl.Range(c2).Select
strSQL = DLookup("db_loc", "tbl_ext_source") & DLookup("area", "tblArea") & "\PICS\" & task_id & ".jpg"
xl.Run "getpic", strSQL
For i = 1 To 10
c2 = "K" & row & ":" & "T" & row
If xl.CountA(xl.Range(c2)) = 0 Then
Exit For
End If
c2 = "K" & row
xl.Range(c2).Select
c2 = xl.ActiveCell.Address
ts_part_num = ""
ts_part_name = ""
pn = ""
pname = ""
pn_id = 0
tool = ""
tool_id = 0
pname = xl.ActiveCell.Value
If pname = "Part Name" Then
Exit For
End If
xl.ActiveCell.Offset(0, 1).Select
pn = xl.ActiveCell.Value
If IsNull(DLookup("part_num", "tblPart_master", "[part_num] = '" & pn & "'")) Then
ts_part_num = pn
ts_part_name = pname
Else
pn_id = DLookup("pn_id", "tblPart_master", "[part_num] = '" & pn & "'")
End If
xl.ActiveCell.Offset(0, 1).Select
qty = xl.ActiveCell.Value
xl.ActiveCell.Offset(0, 1).Select
model_info = xl.ActiveCell.Value
xl.ActiveCell.Offset(0, 1).Select
color = xl.ActiveCell.Value
xl.ActiveCell.Offset(0, 1).Select
dest = xl.ActiveCell.Value
xl.ActiveCell.Offset(0, 1).Select
tool = xl.ActiveCell.Value
If Len(tool) > 1 Then
If IsNull(DLookup("tool_id", "tblTools", "[tool] = '" & tool & "'")) Then
strSQL = "INSERT INTO tblTools (tool, tool_type_id ) " _
& "Values ('" & tool & "',1)"
db.Execute strSQL
lid = DMax("tool_id", "tblTools")
strSQL = "INSERT INTO " _
& "tblAudit (EditDate, RecordSource, RecordID, User, Field, BeforeValue, AfterValue) " _
& "VALUES (Now(), ""tblTools"", '" & lid & "', '" & fosUserName() & "', ""tool"", ""New Record"", '" & tool & "')"
db.Execute strSQL
End If
tool_id = DLookup("tool_id", "tblTools", "[tool] = '" & tool & "'")
End If
xl.ActiveCell.Offset(0, 1).Select
socket = xl.ActiveCell.Value
xl.ActiveCell.Offset(0, 1).Select
torque = xl.ActiveCell.Value
xl.ActiveCell.Offset(0, 1).Select
misc = xl.ActiveCell.Value
strSQL = "INSERT INTO tblTask_steps ( task_id ) " _
& " Values ( " & task_id & " )"
db.Execute strSQL
task_step_id = DMax("task_step_id", "tblTask_steps")
strSQL = "INSERT INTO " _
& "tblAudit (EditDate, RecordSource, RecordID, User, Field, BeforeValue, AfterValue) " _
& "VALUES (Now(), ""tblTask_steps"", '" & task_step_id & "', '" & fosUserName() & "', ""ALL"", ""New Record"", ""New record for PCD "" & " & pcd_id & ")"
db.Execute strSQL
strSQL = "SELECT tblTask_steps.* " _
& "FROM tblTask_steps " _
& "WHERE (((tblTask_steps.task_step_id)=" & task_step_id & "))"
Set rs = db.OpenRecordset(strSQL)
If Len(ts_part_name) > 0 Then
rs.Edit
rs!ts_part_name = ts_part_name
rs.Update
End If
If Len(ts_part_num) > 0 Then
rs.Edit
rs!ts_part_num = ts_part_num
rs.Update
End If
If pn_id > 0 Then
rs.Edit
rs!pn_id = pn_id
rs.Update
End If
If qty > 0 Then
rs.Edit
rs!qty = qty
rs.Update
End If
If Len(model_info) > 0 Then
rs.Edit
rs!model_info = model_info
rs.Update
End If
If Len(color) > 0 Then
rs.Edit
rs!color = color
rs.Update
End If
If Len(dest) > 0 Then
rs.Edit
rs!dest = dest
rs.Update
End If
If tool_id > 0 Then
rs.Edit
rs!tool_id = tool_id
rs.Update
End If
If Len(socket) > 0 Then
rs.Edit
rs!socket = socket
rs.Update
End If
If Len(torque) > 0 Then
rs.Edit
rs!torque = torque
rs.Update
End If
If delta > 0 Then
rs.Edit
rs!delta = delta
rs.Update
End If
If Len(misc) > 0 Then
rs.Edit
rs!misc = misc
rs.Update
End If
xl.Range(c2).Select
xl.ActiveCell.Offset(1, 0).Select
row = xl.ActiveCell.row()
Next i
ts_sec = 0
xl.Range(c1).Select
xl.ActiveCell.Offset(1, 0).Select
If xl.ActiveCell.Column() <> 3 Then
row = xl.ActiveCell.row()
c1 = "C" & row + 1
xl.Range(c1).Select
End If
If xl.ActiveCell.Value = "Task Description" Then
xl.ActiveCell.Offset(1, 0).Select
If xl.ActiveCell.Column() <> 3 Then
row = xl.ActiveCell.row()
c1 = "C" & row + 1
xl.Range(c1).Select
End If
End If
If IsEmpty(xl.ActiveCell) Then
strSQL = DLookup("db_loc", "tbl_ext_source") & DLookup("area", "tblArea") & "\PICS\" & task_id & "_2.jpg"
xl.Run "getpic", strSQL
xl.ActiveCell.Offset(1, 0).Select
If xl.ActiveCell.Column() <> 3 Then
row = xl.ActiveCell.row()
c1 = "C" & row + 1
xl.Range(c1).Select
End If
End If
If xl.ActiveCell.Value = "Task Description" Then
xl.ActiveCell.Offset(1, 0).Select
If xl.ActiveCell.Column() <> 3 Then
row = xl.ActiveCell.row()
c1 = "C" & row + 1
xl.Range(c1).Select
End If
End If
c1 = xl.ActiveCell.Address
st_seq = st_seq + 1
seq = seq + 1
Loop
xl.ActiveSheet.Next.Select
Next J
xl.Application.ScreenUpdating = True
strSQL = "UPDATE tblTask SET tblTask.image_id = [task_id] " _
& "WHERE (((tblTask.pcd_id)=" & pcd_id & "))"
db.Execute strSQL
Call recal_secs(1, pcd_id, 0)
Call sort_stat_all(pcd_id)
MsgBox "The PCD has been imported. Go to stations and assure the zones are correct."
Set rs = Nothing
Set db = Nothing
Exit_frmMe_home_lbl_WV_import:
Exit Sub
Err_frmMe_home_lbl_WV_import:
Call LogError(Err.Number, Err.Description, "frmMe_home_lbl_WV_import()")
Resume Exit_frmMe_home_lbl_WV_import
End Sub
As I tried suggesting in my above comment, it looks that the way you designed the code (probably, mostly based on macro recorder...), using an unjustified number of selecting, makes the code erroring on the respective line because of the fact that a Next sheet does not exist after the last one...
If you want keeping the code as it is and only solve the error, please, try inserting above the problematic code line, the next one:
If J = xl.ActiveWorkbook.Worksheets.Count Then Exit For
But your code is not efficient, at all. The next part, for instance:
xl.Workbooks("P1_PCD.xlsm").Activate
xl.Sheets(1).Select
xl.Range("B1").Select
pcd_title = xl.Range("B1").value
should be replaced with the more efficient one, not involving any Activation/selection:
Dim ws As Object
Set ws = xl.Workbooks("P1_PCD.xlsm")
pcd_title = ws.Range("B1").value
Then, the way of looping between the sheets is also not efficient. Activating the sheet and selecting any range to be used only consumes Excel resources. Instead of the way you use:
For J = 1 To xl.ActiveWorkbook.Worksheets.Count
you can do it in a different, more efficient way:
Dim sh As Object
For each sh in xl.ActiveWorkbook.Worksheets
station = sh.Range("O3").Value
'your code...
'instead of
'xl.Range(c1).Select
'task = xl.ActiveCell.Value
'you should use:
task = sh.Range(c1).Value ' or better
task = sh.Range("C6").Value 'and eliminate c1 useless variable...
'it is at least strange to use
'c1 = "C" & row + 1
'xl.Range(c1).Select
'instead of directly:
sh.Range("C" & row + 1) 'selection is useless, anyhow...
Next sh
Your code is too long, you do not explain in words what you want accomplishing and I cannot spend too much time to deduce what you try doing. I am only suggesting some things necessary to be changed in order to improve the code quality and speed...
I would like to take the value from C6 for my sql query. But, I would like to do it in case if C6 is not empty. I don't know how translate this option in my code. My code is :
Public Sub INFO_PROTO34(ByRef strQ As String)
Dim RECSET As New ADODB.Recordset
RECSET.Open "select proto.b_perf_cma as b_perf_cma, proto.b_perf_supp_ann as b_perf_supp_ann, proto.b_perf_ctrat_gar as b_perf_ctrat_gar from db_dossier sousc,db_produit prod, db_protocole proto" & _
" where sousc.no_police = Range("C6") and sousc.cd_dossier = 'SOUSC' and sousc.lp_etat_doss not in ('ANNUL','A30','IMPAY') and sousc.is_produit = prod.is_produit and '" & strQ & "' = proto.is_protocole ", cnn_Pegase, adOpenDynamic, adLockBatchOptimistic
If Not RECSET.EOF Then
Worksheets("1 - Feuille de Suivi Commercial").Range("Calcul_Perf_Contrat_et_Orient").Value = RECSET.Fields("b_perf_ctrat_gar").Value
Else
Worksheets("1 - Feuille de Suivi Commercial").Range("Calcul_Perf_Contrat_et_Orient").Value = "0"
End If
RECSET.Close
End Sub
Thank you very much for you suggestions
For example:
Public Sub INFO_PROTO34(ByRef strQ As String)
Dim RECSET As New ADODB.Recordset, v
v = Range("C6").Value 'Activesheet? Really need a specific worksheet here
If Len(v) > 0 Then
RECSET.Open " select proto.b_perf_cma as b_perf_cma, proto.b_perf_supp_ann as b_perf_supp_ann, " & _
" proto.b_perf_ctrat_gar as b_perf_ctrat_gar from db_dossier sousc,db_produit prod, db_protocole proto" & _
" where sousc.no_police = " & v & " and sousc.cd_dossier = 'SOUSC' and " & _
" sousc.lp_etat_doss not in ('ANNUL','A30','IMPAY') and sousc.is_produit = prod.is_produit" & _
" and '" & strQ & "' = proto.is_protocole ", cnn_Pegase, adOpenDynamic, adLockBatchOptimistic
With Worksheets("1 - Feuille de Suivi Commercial").Range("Calcul_Perf_Contrat_et_Orient")
If Not RECSET.EOF Then
.Value = RECSET.Fields("b_perf_ctrat_gar").Value
Else
.Value = "0"
End If
End With
RECSET.Close
End If
End Sub
If sousc.no_police is not numeric then add single-quotes around the value.
Before the RECSET.OPEN you can try using the IsEmpty method
I didn't test this out on VBA script yet but here's how I'd change your code to take C6 cell into account depending if its blank or not:
Public Sub INFO_PROTO34(ByRef strQ As String)
Dim RECSET As New ADODB.Recordset
if IsEmpty(Range("C6").value) = true then
' if C6 cell is blank or empty it will do the SQL without the C6 cell value
RECSET.Open "select proto.b_perf_cma as b_perf_cma, proto.b_perf_supp_ann as b_perf_supp_ann, proto.b_perf_ctrat_gar as b_perf_ctrat_gar from db_dossier sousc,db_produit prod, db_protocole proto" & _
" where sousc.cd_dossier = 'SOUSC' and sousc.lp_etat_doss not in ('ANNUL','A30','IMPAY') and sousc.is_produit = prod.is_produit and '" & strQ & "' = proto.is_protocole ", cnn_Pegase, adOpenDynamic, adLockBatchOptimistic
Else
' in this case the cell C6 is not empty/blank so it will use your existing SQL statement
RECSET.Open "select proto.b_perf_cma as b_perf_cma, proto.b_perf_supp_ann as b_perf_supp_ann, proto.b_perf_ctrat_gar as b_perf_ctrat_gar from db_dossier sousc,db_produit prod, db_protocole proto" & _
" where sousc.no_police = Range("C6") and sousc.cd_dossier = 'SOUSC' and sousc.lp_etat_doss not in ('ANNUL','A30','IMPAY') and sousc.is_produit = prod.is_produit and '" & strQ & "' = proto.is_protocole ", cnn_Pegase, adOpenDynamic, adLockBatchOptimistic
end if
If Not RECSET.EOF Then
Worksheets("1 - Feuille de Suivi Commercial").Range("Calcul_Perf_Contrat_et_Orient").Value = RECSET.Fields("b_perf_ctrat_gar").Value
Else
Worksheets("1 - Feuille de Suivi Commercial").Range("Calcul_Perf_Contrat_et_Orient").Value = "0"
End If
RECSET.Close
End Sub
See https://www.techonthenet.com/excel/formulas/isempty.php for more information on the IsEmpty method.
My code is posted below. I can't get the values in ranges "test2" and "test3". I have only the value in range "test". Do I need to modify the code ?
Thank you very much for your suggestions !
Public Sub INFO_PROTO(NO_POLICE As String)
Dim RECSET As New ADODB.Recordset
RECSET.Open "select proto.b_perf_cma as b_perf_cma, proto.b_perf_supp_ann as b_perf_supp_ann, proto.b_perf_ctrat_gar as b_perf_ctrat_gar from db_dossier sousc, db_produit prod, db_protocole proto" & _
" where sousc.no_police = '" & NO_POLICE & "' and sousc.cd_dossier = 'SOUSC' and sousc.lp_etat_doss not in ('ANNUL','A30','IMPAY') and sousc.is_produit = prod.is_produit and sousc.is_protocole = proto.is_protocole ", cnn_Pegase, adOpenDynamic, adLockBatchOptimistic
If Not RECSET.EOF Then
Worksheets("1 - Feuille de Suivi Commercial").Range("test").Value = RECSET.Fields("b_perf_cma").Value
Worksheets("1 - Feuille de Suivi Commercial").Range("test2").Value = RECSET.Fields("b_perf_supp_ann").Value
Worksheets("1 - Feuille de Suivi Commercial").Range("test3").Value = RECSET.Fields("b_perf_ctrat_gar").Value
Else
Worksheets("1 - Feuille de Suivi Commercial").Range("test").Value = "NC"
Worksheets("1 - Feuille de Suivi Commercial").Range("test2").Value = "NC"
Worksheets("1 - Feuille de Suivi Commercial").Range("test3").Value = "NC"
End If
RECSET.Close
End Sub
Try this - it will replace any empty values with zeros
Public Sub INFO_PROTO(NO_POLICE As String)
Dim RECSET As New ADODB.Recordset
RECSET.Open "select proto.b_perf_cma as b_perf_cma, proto.b_perf_supp_ann as " & _
" b_perf_supp_ann, proto.b_perf_ctrat_gar as b_perf_ctrat_gar " & _
"from db_dossier sousc, db_produit prod, db_protocole proto" & _
" where sousc.no_police = '" & NO_POLICE & "' and sousc.cd_dossier = 'SOUSC' " & _
" and sousc.lp_etat_doss not in ('ANNUL','A30','IMPAY') and " & _
"sousc.is_produit = prod.is_produit and sousc.is_protocole = proto.is_protocole ", _
cnn_Pegase, adOpenDynamic, adLockBatchOptimistic
'use a With block to remove repetition
With ThisWorkbook.Worksheets("1 - Feuille de Suivi Commercial")
If Not RECSET.EOF Then
.Range("test").Value = CheckValue(RECSET.Fields("b_perf_cma").Value)
.Range("test2").Value = CheckValue(RECSET.Fields("b_perf_supp_ann").Value)
.Range("test3").Value = CheckValue(RECSET.Fields("b_perf_ctrat_gar").Value)
Else
.Range("test").Value = "NC"
.Range("test2").Value = "NC"
.Range("test3").Value = "NC"
End If
End With
RECSET.Close
End Sub
Function CheckValue(v)
'Default to zero if null
CheckValue = iif(Len(v) = 0, 0, v)
End Function
Newbie here.
I use Excel as a front end and Access as a back end to store data. I am trying to take a query and write the values to an Access table using VBA in Excel. I get an Either BOF or EOF is True error, and when I run the SQL statement in Access, I get records.
Any feedback would be very much appreciated. Thank you in advance.
Here is my code:
Sub Write_Timesheet_AJ()
'**********************************************JGT**********************************************
'Transpose Data for HCS
'2018.09.17
'**********************************************JGT**********************************************
strPath1 = "C:\Reports\Timesheets\"
strFile1 = "Timesheets.accdb"
strDB = strPath1 & strFile1
Conn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & strDB & "; Persist Security Info=False;"
Conn.Open strDB
Conn.CursorLocation = adUseClient
'Clear table
strSQL = "Delete * From tbl_Timesheet_AJ;"
Set rs2 = Conn.Execute(strSQL)
'Transpose Data
strSQL = "Select VisitDate As VisitDt, PatientName, vw_Days_Worked_AJ.CaregiverCode As CaregiverCode, CaregiverName as AideName, CoordinatorName As Coordinator, " _
& "Street_1 As Street1, Street_2 As Street2, City1 As City, State1 as State, Zip, [Language] as L1 " _
& "From vw_Days_Worked_AJ Left Join vw_Caregiver_Info_AJ On vw_Days_Worked_AJ.CaregiverCode = vw_Caregiver_Info_AJ.CaregiverCode;"
Set rs1 = Conn.Execute(strSQL)
If rs1.RecordCount = 0 Then 'Record count check
Debug.Print strSQL
Debug.Print rs1.BOF
Debug.Print rs1.EOF
rs1.Close
Set rs1 = Nothing
Conn.Close
' MsgBox "There are no records; please check data."
Else
rs1.MoveFirst
rsCount1 = rs1.RecordCount
ReDim arrData1(rsCount1)
For loopX = 1 To rsCount1
With arrData1(loopX)
.VisitDt = Format(rs1.Fields("VisitDt"), "m/dd")
.WkEndDt = Get_Fri_Dt(CDate(rs1.Fields("VisitDt")))
.DayOfWk = Left(Get_Day_of_Wk(CDate(rs1.Fields("VisitDt"))), 3)
.PatientName = rs1.Fields("PatientName")
.CaregiverCode = rs1.Fields("CaregiverCode")
.AideName = rs1.Fields("AideName")
.Coordinator = rs1.Fields("Coordinator")
If IsNull(rs1.Fields("Street1")) Then .Street1 = " " Else .Street1 = rs1.Fields("Street1")
If IsNull(rs1.Fields("Street2")) Then .Street2 = " " Else .Street2 = rs1.Fields("Street2")
If IsNull(rs1.Fields("City")) Then .City = " " Else .City = rs1.Fields("City")
If IsNull(rs1.Fields("State")) Then .State = " " Else .State = rs1.Fields("State")
If IsNull(rs1.Fields("Zip")) Then .Zip = " " Else .Zip = rs1.Fields("Zip")
If IsNull(rs1.Fields("L1")) Then .L1 = " " Else .L1 = rs1.Fields("L1")
strInsert = "Insert Into tbl_Timesheet_AJ " _
& "(WkEndDt, PatientName, CaregiverCode, AideName, Coordinator, " & .DayOfWk & ", " _
& "AideName2, CaregiverCode2, Street1, Street2, City, State, Zip, L1) " _
& "Values (#" & .WkEndDt & "#, '" & .PatientName & "', '" & .CaregiverCode & "', " _
& "'" & .AideName & "', '" & .Coordinator & "', '" & .VisitDt & "', '" & .AideName & "', " _
& "'" & .CaregiverCode & "', '" & .Street1 & "', '" & .Street2 & "', '" & .City & "', " _
& "'" & .State & "', '" & .Zip & "', '" & .L1 & "');"
Set rs2 = Conn.Execute(strInsert)
rs1.MoveNext
End With
Next loopX
rs1.Close
Set rs1 = Nothing
Conn.Close
End If
End Sub