Extract employees between 2 Hire Dates VBA and SQL - sql

I have designed a macro which should extract from a workbook database all employees who were hired between 2 Dates.
Unfortunatley I'm getting a error mesage when I run the query.
Error:
Data Type mismatch in criteria expression.
I don't know how to fix the issue.
My regional settings:
Short date: dd.MM.yyyy
Long date: dddd, d.MMMM.yyyy
First day of week: Monday
Here the code:
Public Sub HIREDATE()
Application.ScreenUpdating = False
Dim cnStr As String
Dim rs As ADODB.Recordset
Dim query As String
Dim fileName As String
Dim pom1 As String
Dim x As String, w, e, blad As String, opis As String
Set w = Application.FileDialog(msoFileDialogFilePicker)
With w
.AllowMultiSelect = False
If .Show = -1 Then
fileName = w.SelectedItems(1)
Else
Exit Sub
End If
End With
cnStr = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & fileName & ";" & _
"Extended Properties=Excel 12.0"
On Error GoTo Anuluj
x = InputBox("Wprowadz dwie daty od do oddzielając je przecinkiem -- Przykład 01.01.2015,01.05.2015")
strg = ""
k = Split(x, ",")
e = Application.CountA(k)
For m = LBound(k) To UBound(k)
If e = 1 Then
strg = strg & " [DEU1$].[Last Start Date] = '" & k(m) & "';"
Exit For
ElseIf e = 2 And e Mod 2 = 0 Then
strg = " [DEU1$].[Last Start Date] BETWEEN '" & CDate(k(m)) & "' AND '" & CDate(k(m + 1)) & "';"
Exit For
End If
Next m
On Error GoTo opiszblad
Set rs = New ADODB.Recordset
query = "SELECT [Emplid], [First Name]+ ' ' +[Last Name] From [DEU1$] WHERE" & strg
rs.Open query, cnStr, adOpenUnspecified, adLockUnspecified
Cells.Clear
Dim cell As Range, i As Long
With Range("A3").CurrentRegion
.Select
For i = 0 To rs.Fields.Count - 1
.Cells(1, i + 1).Value = rs.Fields(i).Name
Next i
Range("A4").CopyFromRecordset rs
.Cells.Select
.EntireColumn.AutoFit
End With
rs.Close
Application.ScreenUpdating = True
Exit Sub
Anuluj:
Exit Sub
opiszblad:
e = Err.Number
blad = Err.Source
opis = Err.Description
opisbledu = MsgBox(e & " " & blad & " " & opis, vbInformation, "Błąd")
Exit Sub
End Sub

You need properly formatted string expressions for your dates and to validate the user input:
If e = 1 And IsDate(k(m)) Then
strg = strg & " [DEU1$].[Last Start Date] = #" & Format(DateValue(k(m)), "yyyy\/mm\/dd") & "#;"
Exit For
ElseIf e = 2 And e Mod 2 = 0 And IsDate(k(m + 1)) Then
strg = " [DEU1$].[Last Start Date] BETWEEN #" & Format(DateValue(k(m)), "yyyy\/mm\/dd") & "# AND #" & Format(DateValue(k(m + 1)), "yyyy\/mm\/dd") & "#;"
Exit For
End If

Related

Access VBA List not populating Data

I have an Access VBA list box with a rowsource that will not populate. It was working last week and after reopening the DB this week, for some reason it will not show the results of my string.
Private Sub PullData(strType As String)
Dim rst As DAO.Recordset
Dim sSQL As String
On Error GoTo Err_PullData
Set rst = CurrentDb.OpenRecordset("SELECT * FROM TBLactionstaken_ARCHIVE", dbOpenDynaset, dbReadOnly)
Select Case strType
Case "Actions"
If Me.Frame388.Value = 1 Then
Me.lstActionsTaken.RowSource = "SELECT TBLactionstaken_ARCHIVE.RecordNumber, TBLactionstaken_ARCHIVE.ActionTakenID, TBLparticipants.[PartSS#], TBLactionstaken_ARCHIVE.ActionDate, TBLactionstaken_ARCHIVE.ActionStatus, TBLactionstaken_ARCHIVE.ReasonID, " & _
"TBLreasons.Description, TBLactionstaken_ARCHIVE.MANHType, TBLactionstaken_ARCHIVE.ProcessedDate, TBLactionstaken_ARCHIVE.PayOutStatus, " & _
"TBLactionstaken_ARCHIVE.PayOutDate FROM (TBLactionstaken_ARCHIVE INNER JOIN TBLparticipants ON TBLactionstaken_ARCHIVE.RecordNumber = " & _
"TBLparticipants.RecordNumber) INNER JOIN TBLreasons ON TBLactionstaken_ARCHIVE.ReasonID = TBLreasons.ReasonID WHERE " & _
"(((TBLactionstaken_ARCHIVE.ActionDate)<= [Form]![txtEndDate] And (TBLactionstaken_ARCHIVE.ActionDate)>= [Form]![txtEndDate]));"
Me.lstActionsTaken.Requery
ElseIf Me.Frame388.Value = 2 Then
Me.lstActionsTaken.RowSource = ""
Else
MsgBox "No Data Available", vbExclamation, "Archive Search"
Exit Sub
End If
Case "Transactions"
lstActionsTaken.Visible = False
lstTransactions.Visible = True
End Select
Exit_PullData:
Exit Sub
Err_PullData:
MsgBox Err.Description
Resume Exit_PullData
End Sub
The list box is set up with 11 columns. It's not throwing an error and I can use the immediate window to determine that my fields have values.
Try with specificly formatted date expressions:
If Me.Frame388.Value = 1 Then
Me.lstActionsTaken.RowSource = _
"SELECT TBLactionstaken_ARCHIVE.RecordNumber, TBLactionstaken_ARCHIVE.ActionTakenID, TBLparticipants.[PartSS#], TBLactionstaken_ARCHIVE.ActionDate, TBLactionstaken_ARCHIVE.ActionStatus, TBLactionstaken_ARCHIVE.ReasonID, " & _
"TBLreasons.Description, TBLactionstaken_ARCHIVE.MANHType, TBLactionstaken_ARCHIVE.ProcessedDate, TBLactionstaken_ARCHIVE.PayOutStatus, " & _
"TBLactionstaken_ARCHIVE.PayOutDate FROM (TBLactionstaken_ARCHIVE INNER JOIN TBLparticipants ON TBLactionstaken_ARCHIVE.RecordNumber = " & _
"TBLparticipants.RecordNumber) INNER JOIN TBLreasons ON TBLactionstaken_ARCHIVE.ReasonID = TBLreasons.ReasonID WHERE " & _
"(TBLactionstaken_ARCHIVE.ActionDate <= #" & Format(Me!txtEndDate.Value, "yyyy\/mm\/dd") & "# And TBLactionstaken_ARCHIVE.ActionDate >= #" & Format(Me!txtEndDate.Value, "yyyy\/mm\/dd") & "#);"
' Not needed: Me.lstActionsTaken.Requery

"Automation Error" "Unspecified Error" When Using Excel-VBA and ADODB Objects

I am creating a macro that looks through a folder, performs a SQL operation on each of the documents, and copies the results into another workbook; however, every time I debug and hit the Set rs = cn.Execute(sql) line I get an
"Automation Error" "Unspecified Error" .
The even weirder thing is that when I just run the code, I get an
"Execute of object _Connection failed" error.
I have tested the SQL code in microsoft SQL server already and each of these statements are almost verbatim with code I have previously got to work.
Option Explicit
Sub hardnessTests()
On Error GoTo ErrorHandling
Dim filename As Variant, n As Long
n = 0
Call turnOff
filename = Dir("T:\Marketing\Data Analytics\GIS Data\Water Quality Portal Data\County Summary Results\*")
While filename <> ""
Dim file As String, cn As Object, rs As Object, sql As String, hardField As ADODB.Field
file = "T:\Marketing\Data Analytics\GIS Data\Water Quality Portal Data\County Summary Results\" & filename
Set cn = CreateObject("ADODB.Connection")
With cn
.Provider = "Microsoft.ACE.OLEDB.12.0"
.connectionstring = "Data Source=" & file & ";Extended Properties=""Excel 12.0 Xml;HDR=YES;Readonly=false;IMEX=0"";"
.Open
End With
sql = "SELECT c.STATEFP, c.COUNTYFP, AVG(CAST(a.ResultMeasureValue AS NUMERIC)) AS Average_Surface_Water_Hardness, COUNT(a.ResultMeasureValue) AS Number_Of_Surface_Water_Tests, " & _
"AVG(CAST(b.ResultMeasureValue AS NUMERIC)) AS Average_Groundwater_Hardness, COUNT(b.ResultMeasureValue) AS Number_Of_Groundwater_Tests " & _
"FROM (SELECT * FROM [Sheet1$] WHERE CAST(LEFT(ActivityStartDate, 4) AS NUMERIC) >= 2010 and ActivityMediaSubdivisionName = 'Surface Water') a, " & _
"(SELECT * FROM [Sheet1$] WHERE CAST(LEFT(ActivityStartDate, 4) AS NUMERIC) >= 2010 AND ActivityMediaSubdivisionName = 'Groundwater') b, " & _
"(SELECT * FROM [Sheet1$] WHERE CAST(LEFT(ActivityStartDate, 4) AS NUMERIC) >= 2010 ) c GROUP BY c.STATEFP, c.COUNTYFP ORDER BY c.STATEFP, c.COUNTYFP"
Set rs = cn.Execute(sql)
Dim wb As Workbook, fieldCount As Long
fieldCount = 0
Set wb = Workbooks.Add
wb.SaveAs "T:\Marketing\Data Analytics\GIS Data\Water Quality Portal Data\County Summary Results\ALL_HARDNESS.xlsx"
If n = 0 Then
wb.Worksheets("Sheet1").Range("A2").CopyFromRecordset rs
Else:
wb.Worksheets("Sheet1").Range("A2").End(xlDown).CopyFromRecordset rs
End If
filename = Dir
n = n + 1
Wend
For Each hardField In rs.Fields
wb.Worksheets("Sheet1").Range("A1").Offset(0, fieldCount) = hardField.Name
fieldCount = fieldCount + 1
Next hardField
Call turnOn
Exit Sub
ErrorHandling:
MsgBox ("Source: " & Err.Source & vbNewLine & "Number: " & Err.Number & vbNewLine & "Description: " & Err.Description & vbNewLine & "Help Context: " & Err.HelpContext)
Done:
End Sub
Private Sub turnOff()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
End Sub
Private Sub turnOn()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = True
End Sub
Thanks for any help!

MS Access query too complex to be evaluated

This query is used to call a specific set of work requests over a period of time, this query takes date inputs and the system number from a form. The query result is then put into another form to view.
I've gone over all VBA code that is relevant to this and there seems to be no problems there however so I have determined that the query is too complex and as I am not too well versed in SQL I am not too sure where to go from here.
This Query also provides a #name? Error viewed in forms
The Query
SELECT tbl_NIMSD_dbo_TIDWRREQ.WO_REQ_NUMBER
,tbl_NIMSD_dbo_TIDWRREQ.WR_TASK_TITLE
,"Click Here" AS [Work Request Description]
,tbl_NIMSD_dbo_TIDWRREQ.SYSTEM_CODE
,tbl_NIMSD_dbo_TIDWRREQ.UNIT
,[tbl_NIMSD_dbo_TIDWRREQ].[Unit] + "-" + [tbl_NIMSD_dbo_TIDWRREQ].[SYSTEM_CODE] + "-" + [tbl_NIMSD_dbo_TIDWRREQ].[EQUIPMENT_NUMBER] AS EQ_TAG
,tbl_NIMSD_dbo_TIDWRREQ.WO_REQ_STATUS
,CDate(Format([WO_REQ_DATE_ENTER], "####\/##\/##")) AS WR_CREATION_DATE
FROM qryfrmOutput
INNER JOIN tbl_NIMSD_dbo_TIDWRREQ ON qryfrmOutput.SCI = tbl_NIMSD_dbo_TIDWRREQ.SYSTEM_CODE
WHERE (
((tbl_NIMSD_dbo_TIDWRREQ.SYSTEM_CODE) = Forms ! frmOutputDarlington ! ListSelectedSystem)
AND (
(CDate(Format([WO_REQ_DATE_ENTER], "####\/##\/##"))) >= Forms ! frmOutputDarlington ! TextStartDate
AND (CDate(Format([WO_REQ_DATE_ENTER], "####\/##\/##"))) <= (Forms ! frmOutputDarlington ! TextEndDate + 1)
)
);
The function that inserts the system code and date,
strSCI = ConcatRelated("[SCI]", "[tblSystemAssignmentList]", "[Facility] = '" & [TempVars]![varFacility] & "' AND [Selected] = True", , " OR ", "(tbl_NIMSD_dbo_TIDWRREQ.SYSTEM_CODE)='")
searchString = "(tbl_NIMSD_dbo_TIDWRREQ.SYSTEM_CODE)=Forms!frmOutputDarlington!ListSelectedSystem"
If InStr(1, SCIList, searchString) <> 0 Then
SCIList = Replace(SCIList, "(tbl_NIMSD_dbo_TIDWRREQ.SYSTEM_CODE)=Forms!frmOutputDarlington!ListSelectedSystem", strSCI)
Else
SCIList = Replace(SCIList, "(tbl_NIMSD_dbo_TIDWRREQ.SYSTEM_CODE)=[Forms]![frmOutputDarlington]![ListSelectedSystem]", strSCI)
End If
ConcatRelated
Dim rs As DAO.Recordset
Dim rsMV As DAO.Recordset
Dim strSQL As String
Dim strOut As String
Dim lngLen As Long
Dim bIsMultiValue As Boolean
ConcatRelated = Null
strSQL = "SELECT " & strField & " FROM " & strTable
If strWhere <> vbNullString Then
strSQL = strSQL & " WHERE " & strWhere
End If
If strOrderBy <> vbNullString Then
strSQL = strSQL & " ORDER BY " & strOrderBy
End If
Set rs = DBEngine(0)(0).OpenRecordset(strSQL, dbOpenDynaset)
bIsMultiValue = (rs(0).Type > 100)
Do While Not rs.EOF
If bIsMultiValue Then
Set rsMV = rs(0).Value
Do While Not rsMV.EOF
If Not IsNull(rsMV(0)) Then
strOut = strOut & rsMV(0) & strSeparator
End If
rsMV.MoveNext
Loop
Set rsMV = Nothing
ElseIf Not IsNull(rs(0)) And strFieldName = "(tblImportedSCRs.System) Like '*" Then
strOut = strOut & strFieldName & rs(0) & "*'" & strSeparator
ElseIf Not IsNull(rs(0)) Then
strOut = strOut & strFieldName & rs(0) & "'" & strSeparator
End If
rs.MoveNext
Loop
rs.Close
lngLen = Len(strOut) - Len(strSeparator)
If lngLen > 0 Then
ConcatRelated = Left(strOut, lngLen)
End If
exit_handler:
Set rsMV = Nothing
Set rs = Nothing
Exit Function
Err_Handler:
MsgBox "Error " & Err.Number & ": " & Err.Description, vbExclamation, "ConcatRelated()"
Resume exit_handler
End Function
When I run the code it should output the requested reports within the requested timeframe, however instead of the actual values it displays #name?
For a start, reduce the code and specify the parameters:
PARAMETERS
Forms!frmOutputDarlington!ListSelectedSystem Long,
Forms!frmOutputDarlington!TextStartDate DateTime,
Forms!frmOutputDarlington!TextEndDate DateTime;
SELECT
tbl_NIMSD_dbo_TIDWRREQ.WO_REQ_NUMBER,
tbl_NIMSD_dbo_TIDWRREQ.WR_TASK_TITLE,
"Click Here" AS [Work Request Description],
tbl_NIMSD_dbo_TIDWRREQ.SYSTEM_CODE,
tbl_NIMSD_dbo_TIDWRREQ.UNIT,
[tbl_NIMSD_dbo_TIDWRREQ].[Unit] & "-" & [tbl_NIMSD_dbo_TIDWRREQ].[SYSTEM_CODE] & "-" & [tbl_NIMSD_dbo_TIDWRREQ].[EQUIPMENT_NUMBER] AS EQ_TAG,
tbl_NIMSD_dbo_TIDWRREQ.WO_REQ_STATUS,
DateValue([WO_REQ_DATE_ENTER]) AS WR_CREATION_DATE
FROM
qryfrmOutput
INNER JOIN
tbl_NIMSD_dbo_TIDWRREQ ON
qryfrmOutput.SCI = tbl_NIMSD_dbo_TIDWRREQ.SYSTEM_CODE
WHERE
tbl_NIMSD_dbo_TIDWRREQ.SYSTEM_CODE = Forms!frmOutputDarlington!ListSelectedSystem
AND
DateValue([WO_REQ_DATE_ENTER]) >= Forms!frmOutputDarlington!TextStartDate
AND
DateValue([WO_REQ_DATE_ENTER]) <= DateAdd("d", 1, Forms!frmOutputDarlington!TextEndDate)

Loop Access error 424 Loop rs to excel

rivate Sub CmdOpenCmtList_Click()
On Error GoTo SubError
Dim xlApp As Excel.Application
Dim xlWkb As Excel.Workbook
Dim xlWks As Excel.Worksheet
Dim i As Integer 'First Row: CmtAwd
Dim j As Integer 'First Row: CmtJaws
Dim k As Integer 'First Row: CmtSick
Dim l As Integer 'Second Row: CmtCust
Dim m As Integer 'Second Row: CmtJun
Dim n As Integer 'Second Row: CmtMain
Dim SQLCmtAwd As String
'Dim SQLCmtAwdChair As String 'no chairman
Dim SQLCmtJaws As String
Dim SQLCmtJawsChair As String
Dim SQLCmtSick As String
Dim SQLCmtSickChair As String
Dim SQLCmtCust As String
Dim SQLCmtCustChair As String
Dim SQLCmtJun As String
Dim SQLCmtJunChair As String
Dim SQLCmtMain As String
Dim SQLCmtMainChair As String
Dim rsCmtAwd As DAO.Recordset
'Dim rsCmtAwdChair As DAO.Recordset 'no chairmen
Dim rsCmtJaws As DAO.Recordset
Dim rsCmtJawsChair As DAO.Recordset
Dim rsCmtSick As DAO.Recordset
Dim rsCmtSickChair As DAO.Recordset
Dim rsCmtCust As DAO.Recordset
Dim rsCmtCustChair As DAO.Recordset
Dim rsCmtJun As DAO.Recordset
Dim rsCmtJunChair As DAO.Recordset
Dim rsCmtMain As DAO.Recordset
Dim rsCmtMainChair As DAO.Recordset
SQLCmtAwd = "SELECT [FirstName] & "" "" & [LastName] AS FullName, TblMembers.CmtAwd, TblMembers.CmtAwd " & _
" FROM TblMembers " & _
" WHERE (((TblMembers.CmtAwd)=True))"
'SQLCmtAwdChair = " SELECT [FirstName] & "" "" & [LastName] AS FullName, TblMembers.CmtAwdChair, [FullName] & "" - Chairman"" AS FullNameChair " & _
' " FROM TblMembers " & _
' " WHERE (((TblMembers.CmtAwdChair)=True))"
SQLCmtJaws = "SELECT [FirstName] & "" "" & [LastName] AS FullName, TblMembers.CmtJaws " & _
" FROM TblMembers " & _
" WHERE (((TblMembers.CmtJaws)=True))"
SQLCmtJawsChair = " SELECT [FirstName] & "" "" & [LastName] AS FullName, TblMembers.CmtJawsChair, [FullName] & "" - Chairman"" AS FullNameChair " & _
" FROM TblMembers " & _
" WHERE (((TblMembers.CmtJawsChair)=True))"
SQLCmtSickChair = " SELECT [FirstName] & "" "" & [LastName] AS FullName, TblMembers.CmtSickChair, [FullName] & "" - Chairman"" AS FullNameChair " & _
" FROM TblMembers " & _
" WHERE (((TblMembers.CmtSickChair)=True))"
SQLCmtSick = "SELECT [FirstName] & "" "" & [LastName] AS FullName, TblMembers.CmtSickChair " & _
" FROM TblMembers " & _
" WHERE (((TblMembers.CmtSick)=True))"
SQLCmtCustChair = " SELECT [FirstName] & "" "" & [LastName] AS FullName, TblMembers.CmtCustChair, [FullName] & "" - Chairman"" AS FullNameChair " & _
" FROM TblMembers " & _
" WHERE (((TblMembers.CmtCustChair)=True))"
SQLCmtCust = "SELECT [FirstName] & "" "" & [LastName] AS FullName, TblMembers.CmtCust " & _
" FROM TblMembers " & _
" WHERE (((TblMembers.CmtCust)=True))"
SQLCmtJunChair = " SELECT [FirstName] & "" "" & [LastName] AS FullName, TblMembers.CmtJunChair, [FullName] & "" - Chairman"" AS FullNameChair " & _
" FROM TblMembers " & _
" WHERE (((TblMembers.CmtJunChair)=True))"
SQLCmtJun = "SELECT [FirstName] & "" "" & [LastName] AS FullName, TblMembers.CmtJun " & _
" FROM TblMembers " & _
" WHERE (((TblMembers.CmtJun)=True))"
SQLCmtMainChair = " SELECT [FirstName] & "" "" & [LastName] AS FullName, TblMembers.CmtMainChair, [FullName] & "" - Chairman"" AS FullNameChair " & _
" FROM TblMembers " & _
" WHERE (((TblMembers.CmtMainChair)=True))"
SQLCmtMain = "SELECT [FirstName] & "" "" & [LastName] AS FullName, TblMembers.CmtMainChair " & _
" FROM TblMembers " & _
" WHERE (((TblMembers.CmtMain)=True))"
Set rsCmtAwd = CurrentDb.OpenRecordset(SQLCmtAwd, dbOpenSnapshot)
'Set rsCmtAwdChair = CurrentDb.OpenRecordset(SQLCmtAwdChair, dbOpenSnapshot)
Set rsCmtJaws = CurrentDb.OpenRecordset(SQLCmtJaws, dbOpenSnapshot)
Set rsCmtJawsChair = CurrentDb.OpenRecordset(SQLCmtJawsChair, dbOpenSnapshot)
Set rsCmtSick = CurrentDb.OpenRecordset(SQLCmtSick, dbOpenSnapshot)
Set rsCmtSickChair = CurrentDb.OpenRecordset(SQLCmtSickChair, dbOpenSnapshot)
Set rsCmtCust = CurrentDb.OpenRecordset(SQLCmtCust, dbOpenSnapshot)
Set rsCmtCustChair = CurrentDb.OpenRecordset(SQLCmtCustChair, dbOpenSnapshot)
Set rsCmtJun = CurrentDb.OpenRecordset(SQLCmtJun, dbOpenSnapshot)
Set rsCmtJunChair = CurrentDb.OpenRecordset(SQLCmtJunChair, dbOpenSnapshot)
Set rsCmtMain = CurrentDb.OpenRecordset(SQLCmtMain, dbOpenSnapshot)
Set rsCmtMainChair = CurrentDb.OpenRecordset(SQLCmtMainChair, dbOpenSnapshot)
Set xlApp = New Excel.Application
Set xlWkb = xlApp.Workbooks.Open(CurrentProject.Path & "\Master\CommitteeList.xlsx")
Set xlWks = xlWkb.Sheets("Sheet1")
xlApp.Visible = True
i = 10 'First Row: CmtAwd
j = 10 'First Row: CmtJaws
k = 10 'First Row: CmtSick
With xlWks
Do While Not rsCmtAwdChair.EOF
.Range("E9").Value = (rsCmtAwdChair!FullNameChair)
rsCmtAwdChair.MoveNext
Loop
End With
With xlWks
Do While Not rsCmtAwd.EOF
.Range("E" & i - 1).Value = Nz(rsCmtAwd!FullName, "")
i = i + 1
rsCmtAwd.MoveNext
Loop
End With
With xlWks
Do While Not rsCmtJawsChair.EOF
.Range("Y9").Value = (rsCmtJawsChair!FullNameChair)
rsCmtJawsChair.MoveNext
Loop
End With
With xlWks
Do While Not rsCmtJaws.EOF
.Range("Y" & j).Value = Nz(rsCmtJaws!FullName, "")
j = j + 1
rsCmtJaws.MoveNext
Loop
End With
With xlWks
Do While Not rsCmtSickChair.EOF
.Range("AS9").Value = (rsCmtSickChair!FullNameChair)
rsCmtSickChair.MoveNext
Loop
End With
With xlWks
Do While Not rsCmtSick.EOF
.Range("AS" & k).Value = Nz(rsCmtSick!FullName, "")
k = k + 1
rsCmtSick.MoveNext
Loop
End With
With xlWks
Do While Not rsCmtCustChair.EOF
.Range("E16").Value = (rsCmtCustChair!FullNameChair)
rsCmtCustChair.MoveNext
Loop
End With
With xlWks
Do While Not rsCmtCust.EOF
.Range("AS" & i).Value = Nz(rsCmtCust!FullName, "")
i = i + 17
rsCmtSick.MoveNext
Loop
End With
With xlWks
Do While Not rsCmtJunChair.EOF
.Range("Y16").Value = (rsCmtJunChair!FullNameChair)
rsCmtJunChair.MoveNext
Loop
End With
With xlWks
Do While Not rsCmtJun.EOF
.Range("Y" & m).Value = Nz(rsCmtJun!FullName, "")
m = m + 1
rsCmtSick.MoveNext
Loop
End With
With xlWks
Do While Not rsCmtMainChair.EOF
.Range("AS16").Value = (rsCmtMainChair!FullNameChair)
rsCmtMainChair.MoveNext
Loop
End With
With xlWks
Do While Not rsCmtMain.EOF
.Range("Y" & n).Value = Nz(rsCmtMain!FullName, "")
n = n + 1
rsCmtMain.MoveNext
Loop
End With
SubExit:
On Error Resume Next
rsCmtAwd.Close
'rsCmtAwdChair.Close
rsCmtJaws.Close
rsCmtJawsChair.Close
rsCmtSick.Close
rsCmtSickChair.Close
rsCmtCust.Close
rsCmtCustChair.Close
rsCmtJun.Close
rsCmtJunChair.Close
rsCmtMain.Close
rsCmtMainChair.Close
Set rsCmtAwd = Nothing
'Set rsCmtAwdChair = Nothing
Set rsCmtJaws = Nothing
Set rsCmtJawsChair = Nothing
Set rsCmtSick = Nothing
Set rsCmtSickChair = Nothing
Set rsCustAwd = Nothing
Set rsCmtCustChair = Nothing
Set rsCmtJun = Nothing
Set rsCmtJunChair = Nothing
Set rsCmtMain = Nothing
Set rsCmtSickMain = Nothing
Exit Sub
SubError:
MsgBox "Error Number: " & Err.Number & "=" & Err.Description, vbCritical + vbOKOnly, "An error occured"
GoTo SubExit
End Sub
Is there a better way to do this. I solved my previous problem, but now I get an error of 424 object required. Before the object error I was getting no record error, I checked the queries all return records.
Is there a better way to loop thru rs and get the output to the excel file, I have about 18 committes that need to have a chairman and 1-5 members. Cells on excel ie... Y16 for Chairman and then in y17 the list of members.
1-
Instead of looping, you can use 'CopyfromRecordSet'. You just need to select the starting cell on each sheet of your Excel file, and the system do the rest.
I give you the Microsoft link:https://msdn.microsoft.com/en-us/library/office/aa223845(v=office.11).aspx
2-
On the 424 Object required problem, did you try to debug the code to find out which line the error occurs?
Hope this can help!

VBA: Error 3265 - "Item not found in this collection"

In Access 2016 I'm trying to open a recordset and save data from it in other variables, but I keep getting this error.
The program itself has more parts, but I only get error in this one, it just update data on its database.
This is my code:
Option Compare Database
Option Explicit
Private Sub btnValidateTimesheet_Click()
' Update timesheet to "Justificat"
Dim intIdTimesheet As Integer
If IsNull(cmbDraftTimesheets.Value) Then
MsgBox("You have to select a timesheet that is Borrador")
Exit Sub
End If
intIdTimesheet = cmbDraftTimesheets.Column(0)
DoCmd.SetWarnings False
DoCmd.RunSQL "update Timesheets set estat = ""Justificat"" where id=" & intIdTimesheet
DoCmd.SetWarnings True
End Sub
Private Sub btnValidateTimesheetLines_Click()
' We select the timesheet_lines for employee, project, activity and dates selected
' For each justification, a new "Justificat" Timesheet is generated which hang timesheet_lines
' ------------------------------- Variables -------------------------------
Dim dictTsLines As Object
Set dictTsLines = CreateObject("Scripting.Dictionary")
' Form inputs
Dim intCodTreb As Integer
Dim strCodProj As String
Dim dateInici, dateFi As Date
Dim intExercici As Integer
' Query strings
Dim strSQLFrom, strSQLWhere As String
Dim strSQLCount, strSQLJustAct, strSQLTsLines As String
' Recordsets
Dim rsCount, rsJustAct, rsTimesheets, rsTsLines As Recordset
' Aux and others...
Dim continue As Integer
Dim intIdJustificacio, intIdTs As Integer
Dim strActivitat As String
' --------------------------------------- Main ---------------------------------------------
' Taking form data
intCodTreb = cmbTreballador.Column(0)
strCodProj = cmbProjecte.Column(1)
dateInici = txtDataInici.Value
dateFi = txtDataFi.Value
' We check the dates are correct
If IsNull(dateInici) Or IsNull(dateFi) Then
MsgBox("Dates can't be null")
Exit Sub
End If
If dateFi < dateInici Then
MsgBox("Start date must be earlier or the same as final date")
Exit Sub
End If
If year(dateInici) <> year(dateFi) Then
MsgBox("Dates must be in the same year")
Exit Sub
End If
intExercici = year(dateInici)
' Make of the clause FROM and WHERE of the select query of timesheet_lines
strSQLFrom = " from (timesheet_lines tsl " & _
" left join timesheets ts on tsl.timesheet_id = ts.id) " & _
" left join justificacions j on j.id = ts.id_justificacio "
strSQLWhere = " where ts.estat = ""Borrador"" " & _
" and tsl.data >= #" & Format(dateInici, "yyyy/mm/dd") & "# " & _
" and tsl.data <= #" & Format(dateFi, "yyyy/mm/dd") & "# "
If Not IsNull(intCodTreb) Then
strSQLWhere = strSQLWhere & " and tsl.cod_treb = " & intCodTreb
End If
If Not IsNull(strCodProj) Then
strSQLWhere = strSQLWhere & " and j.cod_proj=""" & strCodProj & """ "
End If
' Alert how much timesheet_lines are going to be validated
strSQLCount = "select count(*) " & strSQLFrom & strSQLWhere
Set rsCount = CurrentDb.OpenRecordset(strSQLCount)
Continue Do = MsgBox( rsCount(0) & " registries are going to be validated" & vbNewLine & _
"Do you want to continue?", vbOKCancel)
If continue <> 1 Then
Exit Sub
End If
' We select the tuples Justificacio, Activitat of timesheet_lines selected
strSQLJustAct = "select distinct ts.id_justificacio " & strSQLFrom & strSQLWhere
Set rsJustAct = CurrentDb.OpenRecordset(strSQLJustAct)
Set rsTimesheets = CurrentDb.OpenRecordset("Timesheets")
' A new timesheet is generated for each tupla
Do While Not rsJustAct.EOF
intIdJustificacio = rsJustAct(0)
strActivitat = rsJustAct(1)
rsTimesheets.AddNew
rsTimesheets!data_generacio = Now()
rsTimesheets!estat = "Justificat"
rsTimesheets!Id_justificacio = intIdJustificacio
rsTimesheets!activitat = strActivitat
rsTimesheets!data_inici = dateInici
rsTimesheets!data_fi = dateFi
rsTimesheets!exercici = intExercici
intIdTs = rsTimesheets!Id
rsTimesheets.Update
' We save the related id of the selected timesheet in a dictionary
dictTsLines.Add intIdJustificacio & "_" & strActivitat, intIdTs
rsJustAct.MoveNext
Loop
' We select all the affected timesheet_lines and we update the related timesheet using the dictionary
strSQLTsLines = "select tsl.id, tsl.timesheet_id, ts.id_justificacio, ts.activitat " & strSQLFrom & strSQLWhere
Set rsTsLines = CurrentDb.OpenRecordset(strSQLTsLines)
With rsTsLines
Do While Not .EOF
.EDIT
intIdJustificacio = !Id_justificacio
strActivitat = !activitat
!timesheet_id = dictTsLines.Item(intIdJustificacio & "_" & strActivitat)
.Update
.MoveNext
Loop
End With
rsTimesheets.Close
Set rsCount = Nothing
Set rsJustAct = Nothing
Set rsTimesheets = Nothing
Set rsTsLines = Nothing
End Sub
Debugger: The error is coming up at the line:
strActivitat = rsJustAct(1)
I checked that the data the recordset is saving exists and it does.
Your recordset contains just one column ("select distinct ts.id_justificacio"), but you are trying to read second column strActivitat = rsJustAct(1)
Add requred column to recordset.