I am trying to get a command working to lookup if objects have been already selected for certain dates. I would like to do this with the Dlookup method, problem is, I am still getting used to SQL syntax. This is the code I am trying to get working:
Dim i, coun as Integer
For i = 1 to 10
If IsNull(DLookup("[Column1]", "Table1", "[Column1] LIKE '*AT 1/*' & i "
And (("[Date_Beg] BETWEEN #" & Me.txtDate1 & "#" AND "#" & Me.txtDate2 & "#")
Or ("[Date_End] BETWEEN #" & Me.txtDate1 & "#" AND "#" & Me.txtDAte2 & "#")))) = True Then
coun = coun
else
coun = coun + 1
End If
When it gets executed, I get an error
Run-time error '13': Type mismatch
EDIT: Please go see my answer to see the code that ended up working for me.
The problem is with the SQL string you are trying to pass into the DLookup function. When you need SQL strings like this I find it best to store them as variable and then pass the variable into the function. Let me know if this works for you.
Sub QueryExample()
Dim i, coun As Integer
Dim strSQL As String
For i = 1 To 10
strSQL = "[Column1] LIKE *AT 1/*" & i
strSQL = strSQL & " And (([Date_Beg] BETWEEN #" & Me.txtDate1 & "# AND #" & Me.txtDAte2 & "#)"
strSQL = strSQL & " Or ([Date_End] BETWEEN #" & Me.txtDate1 & "# AND #" & Me.txtDAte2 & "#))"
'Debug.Print strSQL
If IsNull(DLookup("[Column1]", "Table1", strSQL)) = True Then
coun = coun
Else
coun = coun + 1
End If
Next i
End Sub
Taking the suggestion from #pheeper and modifying his code a little bit I got the program working. This is what worked:
Dim i, coun as Integer
For i = 1 To 10
strSQL = "[Column1] LIKE ""*AT 1/" & i & "*"""
strSQL = strSQL & " And (([Date_Beg] BETWEEN #" & Me.txtDate1 & "# AND #" & Me.txtDate2 & "#)"
strSQL = strSQL & " Or ([Date_End] BETWEEN #" & Me.txtDate1 & "# AND #" & Me.txtDate2 & "#))"
'Debug.Print strSQL
If IsNull(DLookup("[Column1]", "Table1", strSQL)) = True Then
coun = coun
Else
coun = coun + 1
End If
Next i
Related
I was wondering if there's a better way
I need to find missing number buckets. There's a set of number buckets in which the weights are distributed. I want to make sure that if the user misses a number somewhere, his attention is drawn to it and hes told that he's missing some buckets, otherwise his data for these will not show.
I already found each missing number but it shows a line for each and the user is only interested in the entire bucket.
so, I need the thing on the left to become the thing on the right. The FROM and TO is what I have to work with.
I have a feeling there's some beautiful VBA solution for this, something with arrays :)
Besides all this ugliness that I wrote, to get the original missing weight, I had to create a table with all weights from 0 to 1000. there has to be a better way
Sub sbMissingBuckets()
Dim vrQDF As Object
Dim vrSQL As String
Dim vrQueryName As String
Dim vrCountsMissingBuckets As Long
sbWOff
DoCmd.RunSQL "DELETE FROM MissingServicesShippingWeightBuckets"
Dim vrRs1 As DAO.Recordset
Dim vrServicesShippingWeightCollectionID As Long
Set vrRs1 = CurrentDb.OpenRecordset("SELECT ServicesShippingWeightBuckets.ServicesShippingWeightCollectionID FROM ServicesShippingWeightBuckets GROUP BY ServicesShippingWeightBuckets.ServicesShippingWeightCollectionID " & _
", ServicesShippingWeightBuckets.IsMultiweight HAVING (((ServicesShippingWeightBuckets.IsMultiweight)=False));")
Do Until vrRs1.EOF
vrServicesShippingWeightCollectionID = vrRs1("ServicesShippingWeightCollectionID")
vrSQL = "SELECT ServicesShippingWeightBuckets.ServicesShippingWeightCollectionID, AllWeights.Weight FROM ServicesShippingWeightBuckets " & _
", AllWeights GROUP BY ServicesShippingWeightBuckets.ServicesShippingWeightCollectionID, AllWeights.Weight, IIf([WeightFromInequalitySymbolID]=1,IIf([WeightToInequalitySymbolID]=3,[Weight]>[WeightFrom] " & _
"AND [Weight]<[WeightTo]) & IIf([WeightToInequalitySymbolID]=4,[Weight]>[WeightFrom] AND [Weight]<=[WeightTo]) & IIf(IsNull([WeightToInequalitySymbolID]),[Weight]>[WeightFrom] " & _
"AND [Weight]<=999999999)) & IIf([WeightFromInequalitySymbolID]=2,IIf([WeightToInequalitySymbolID]=3,[Weight]>=[WeightFrom] AND [Weight]<[WeightTo]) & IIf([WeightToInequalitySymbolID]=4,[Weight]>=[WeightFrom] " & _
"AND [Weight]<=[WeightTo]) & IIf(IsNull([WeightToInequalitySymbolID]),[Weight]>=[WeightFrom] AND [Weight]<=999999999)), ServicesShippingWeightBuckets.IsMultiweight " & _
"HAVING (((ServicesShippingWeightBuckets.ServicesShippingWeightCollectionID)=" & vrServicesShippingWeightCollectionID & ") AND ((IIf([WeightFromInequalitySymbolID]=1,IIf([WeightToInequalitySymbolID]=3,[Weight]>[WeightFrom] " & _
"AND [Weight]<[WeightTo]) & IIf([WeightToInequalitySymbolID]=4,[Weight]>[WeightFrom] AND [Weight]<=[WeightTo]) & IIf(IsNull([WeightToInequalitySymbolID]),[Weight]>[WeightFrom] " & _
"AND [Weight]<=999999999)) & IIf([WeightFromInequalitySymbolID]=2,IIf([WeightToInequalitySymbolID]=3,[Weight]>=[WeightFrom] AND [Weight]<[WeightTo]) & IIf([WeightToInequalitySymbolID]=4,[Weight]>=[WeightFrom] " & _
"AND [Weight]<=[WeightTo]) & IIf(IsNull([WeightToInequalitySymbolID]),[Weight]>=[WeightFrom] AND [Weight]<=999999999)))=-1) " & _
"AND ((ServicesShippingWeightBuckets.IsMultiweight)=False)) ORDER BY AllWeights.Weight;"
vrQueryName = "qMissingBucketsBase"
fnDeleteObjectIfExists "Query", vrQueryName
Set vrQDF = CurrentDb.CreateQueryDef(vrQueryName, vrSQL)
'count qMissingBuckets
vrCountsMissingBuckets = dCount("cTo", "qMissingBuckets")
'if 0 do nothing
If vrCountsMissingBuckets > 0 Then
'loop thoruhg and onl add records to the table if the diff is more than 1
DoCmd.OpenQuery "qMissingBuckets2"
DoCmd.OpenQuery "qMissingBuckets3"
Dim vrRs2 As DAO.Recordset
Dim vrFrom As Long
Dim vrTo As Long
Dim vrDiff As Long
Dim vrPlaceholder As Boolean
Dim vrFromPlaceholder As Variant
Set vrRs2 = CurrentDb.OpenRecordset("mtT")
Do Until vrRs2.EOF
vrFrom = vrRs2("cFrom")
vrTo = vrRs2("cTo")
vrDiff = vrRs2("cDiff")
If vrDiff > 1 Then
If vrPlaceholder = False Then
If vrDiff < 99999 Then
DoCmd.RunSQL "INSERT INTO MissingServicesShippingWeightBuckets (ServicesShippingWeightCollectionID, ServicesShippingWeightBucket, WeightFromInequalitySymbolID, WeightFrom, WeightToInequalitySymbolID, WeightTo) SELECT " & vrServicesShippingWeightCollectionID & _
", '>=" & vrFrom & " and <" & vrTo & "', 2 as WeightFromInequalitySymbolID, " & vrFrom & " as WeightFrom, 3 as WeightToInequalitySymbolID, " & vrTo & " as WeightTo"
End If
Else
DoCmd.RunSQL "INSERT INTO MissingServicesShippingWeightBuckets (ServicesShippingWeightCollectionID, ServicesShippingWeightBucket, WeightFromInequalitySymbolID, WeightFrom, WeightToInequalitySymbolID, WeightTo) SELECT " & vrServicesShippingWeightCollectionID & _
", '>=" & vrFromPlaceholder & " and <" & vrTo & "', 2 as WeightFromInequalitySymbolID, " & vrFromPlaceholder & " as WeightFrom, 3 as WeightToInequalitySymbolID, " & vrTo & " as WeightTo"
vrPlaceholder = False
vrFromPlaceholder = Null
End If
ElseIf vrDiff = 1 Then
If vrPlaceholder = False Then
vrFromPlaceholder = vrFrom
vrPlaceholder = True
End If
End If
vrRs2.MoveNext
Loop
vrRs2.Close
Set vrRs2 = Nothing
End If
vrRs1.MoveNext
Loop
vrRs1.Close
Set vrRs1 = Nothing
sbWOn
End Sub
I am running some EXCEL VBA code to update the contents of an ACCESS database table along the lines suggested here:
IF ##Rowcount = 0 -- SQL Syntax Error in Access
. When I execute the SELECT query, EXCEL VBA gives this error message:
Run-time error 424: Object required
I extracted the SQL string from the VBA Watch window and ran it as a Query in ACCESS. The first time I did this, there were no records becasue the table was empty, so I ran the INSERT query in ACCESS and then tried running the VBA code but got the same error message.
The code is here:
Public db As DAO.Database
' Open database
Public Sub OpenMdtDatabase()
Set db = DBEngine(0).OpenDatabase("SL_MDT_data_v1.accdb")
End Sub
' Update DB table
Sub UpdateDb()
' Initialise
Dim rs As DAO.Recordset
Set xlSht = Sheets("plot_data")
' Open database
Call OpenMdtDatabase
' Get the data to store
sname = xlSht.Cells(6, "R").Value
xfill = xlSht.Cells(6, "S").Value
xedge = xlSht.Cells(6, "T").Value
xstyl = xlSht.Cells(6, "U").Value
xsize = xlSht.Cells(6, "V").Value
' SQL stuff
sqlTxtSelect = "SELECT SeriesName FROM SeriesProperties WHERE SeriesName ='" & sname & "';"
sqlTxtUpdate = "UPDATE SeriesProperties " & _
sqlTxtUpdate = "SET SeriesFill = " & xfill & ", " & _
sqlTxtUpdate = "SeriesEdge = " & xedge & ", " & _
sqlTxtUpdate = "SeriesStyle = " & xstyl & ", " & _
sqlTxtUpdate = "SeriesSize = " & xsize & " " & _
sqlTxtUpdate = "WHERE SeriesName = '" & sname & "';"
sqlTxtInsert = "INSERT INTO SeriesProperties('" & sname & "') " & _
sqlTxtInsert = "VALUES(" & xfill & ", " & xedge & ", " & xstyl & ", " & xsize & ");"
Set rs = db.OpenRecordset(sqlTxtSelect)
If rs.RecordCount = 0 Then
DoCmd.RunSQL (sqlTxtInsert)
Else
DoCmd.RunSQL (sqlTxtUpdate)
End If
End Sub
I am guessing that there is something wrong with the SQL SELECT string. I tried setting this directly using
SELECT SeriesName FROM SeriesProperties WHERE SeriesName ='14/10-2:F2F_SLMC'
but still get the same error message. I have also tried removing the colon ...
The problem lies with the statement
DoCmd.RunSQL (sqlTxtInsert)
If I change this to
db.Execute (sqlTxtInsert)
then everything is fine. Should have scrolled to the end of the answer at the original link ....
I have code that is looping through an array of member numbers and retrieving records for each. Each time, I need to use the count of the records returned up to 12. However, once the variable that is to hold the count is set, it will not reset with the next call. It also "jumps" from the first to the last record rather than looping through each. In other words, if there are 4 records returned by the recordset, it will execute for the first and the last and then give an error of "No Current Record" Here is my code:
Dim x As Integer
For i = 1 To intMembers
strGetMemberInfo = "SELECT PatientRecords.[Medication Name], PatientRecords.[First Name], PatientRecords.[Last Name],PatientRecords.[doc phone]" _
& " FROM PatientRecords WHERE member_no ='" & arrMembers(i) & "'"
Set rstMedicine = dbs.OpenRecordset(strGetMemberInfo, dbOpenSnapshot)
Dim intMedicine As Integer
intMedicine = rstMedicine.RecordCount
If intMedicine > 12 Then
intMedicine = 12
End If
Do Until rstMedicine.EOF
For x = 1 To intMedicine
strMedicationField = strMedication & x
strDoctorFNameField = strDoctorFName & x
strDoctorLNameField = strDocotrLName & x
strDoctorPhoneField = strDoctorPhone & x
strSQL = "UPDATE TransformationTable SET " & strMedicationField & " = '" & rstMedicine.Fields("[Medication Name]").Value & "'," & strDoctorFNameField & " = '" & rstMedicine.Fields("[First Name]").Value & "', " & strDoctorLNameField & " = '" & Replace(rstMedicine.Fields("[Last Name]"), "'", "''") & "', " & strDoctorPhoneField & " = '" & rstMedicine.Fields("[doc phone]").Value & "' WHERE member_no ='" & arrMembers(i) & "'"
dbs.Execute strSQL
rstMedicine.MoveNext
Next x
Loop
rstMedicine.Close
Set rstMedicine = Nothing
Next i
In the above code, intMedicinegets set by the first recordset and NEVER changes even though rstMedicine.RecordCount does change.
Any help is appreciated
You have 2 different issues. First, use rstMedicine.MoveLast to move to the bottom of the recordset and get the full count. Second. Your limiting the number of "cycles" to 12, but you are not exiting the loop after intMedicine is 12, so it is still trying to get to the end of the recordset because your code says "Do Until rstMedicine.EOF". Change your code to this:
Dim x As Integer
For i = 1 To intMembers
strGetMemberInfo = "SELECT PatientRecords.[Medication Name], PatientRecords.[First Name], PatientRecords.[Last Name],PatientRecords.[doc phone]" _
& " FROM PatientRecords WHERE member_no ='" & arrMembers(i) & "'"
Set rstMedicine = dbs.OpenRecordset(strGetMemberInfo, dbOpenSnapshot)
rstMedicine.MoveLast
Dim intMedicine As Integer
intMedicine = rstMedicine.RecordCount
If intMedicine > 12 Then
intMedicine = 12
End If
rstMedicine.MoveFirst
Do Until rstMedicine.EOF
For x = 1 To intMedicine
strMedicationField = strMedication & x
strDoctorFNameField = strDoctorFName & x
strDoctorLNameField = strDocotrLName & x
strDoctorPhoneField = strDoctorPhone & x
strSQL = "UPDATE TransformationTable SET " & strMedicationField & " = '" & rstMedicine.Fields("[Medication Name]").Value & "'," & strDoctorFNameField & " = '" & rstMedicine.Fields("[First Name]").Value & "', " & strDoctorLNameField & " = '" & Replace(rstMedicine.Fields("[Last Name]"), "'", "''") & "', " & strDoctorPhoneField & " = '" & rstMedicine.Fields("[doc phone]").Value & "' WHERE member_no ='" & arrMembers(i) & "'"
dbs.Execute strSQL
rstMedicine.MoveNext
If x = 12 Then
Exit Do
End If
Next x
Loop
rstMedicine.Close
Set rstMedicine = Nothing
Next i
Good day. I'm a little stumped about what is happening in my code. I have a userform which collects txtQntyRecd and cboSupplySource. I calculate the lookupValue. And it works just fine. It successfully places the txtQntyRecd in the correct tblWarehouseLocations.WQuantity location. The code is:
updateQnty = "UPDATE tblSupplySources INNER JOIN ((tblWarehouseLocations " & _
"INNER JOIN tblSupplySource_WarehouseLocation ON tblWarehouseLocations.WLocation_ID = tblSupplySource_WarehouseLocation.SWLocation_ID)) " & _
"ON tblSupplySources.SupplySourceID = tblSupplySource_WarehouseLocation.Supply_Source_ID " & _
"SET tblWarehouseLocations.WQuantity = '" & Me.txtQntyRecd & "'" & _
"WHERE (((tblSupplySource_WarehouseLocation.Supply_Source_ID)= " & Me.cboSupplySource & ") " & _
" AND ((tblWarehouseLocations.WLocation_ID)=" & lookupValue & "))"
CurrentDb.Execute updateQnty, dbFailOnError
What I want to do is add the next quantity to the same location. I get weird results if I change the SET statement to the following:
SET tblWarehouseLocations.WQuantity = tblWarehouseLocations.WQuantity + '" & Me.txtQntyRecd & "'"
If I put 200 in the first statement, I get 200 in my WQuantity field. When I change to the second statement and I try to add 1 to the 200 I get a result of 211. If I add 1 again, the result is 223. Add 1 again, the result is 236.
Could someone explain what is happening and why the results aren't 201, 202 and 203? In the future I will need to subtract quantities from WQuantity as well.
Thanks
You're adding quotes around an integer and appending it as a string. Change it to:
".....
SET tblWarehouseLocations.WQuantity = tblWarehouseLocations.WQuantity + " & val(Me!txtQntyRecd) & "....
...."
I've changed the . to a ! as I think it's still a nice distinction between objects properties and controls, and used the val function as it converts the string number value to the integer value.
This is your query in full:
' When I use values from controls, I like to store them in vars
Dim quantityReceived As integer
quantityReceived = val(Me!txtQntyRecd)
updateQnty = "UPDATE tblSupplySources INNER JOIN ((tblWarehouseLocations " & _
"INNER JOIN tblSupplySource_WarehouseLocation ON tblWarehouseLocations.WLocation_ID = tblSupplySource_WarehouseLocation.SWLocation_ID)) " & _
"ON tblSupplySources.SupplySourceID = tblSupplySource_WarehouseLocation.Supply_Source_ID " & _
"SET tblWarehouseLocations.WQuantity = tblWarehouseLocations.WQuantity + " & quantityReceived & _
" WHERE (((tblSupplySource_WarehouseLocation.Supply_Source_ID)= " & Me.cboSupplySource & ") " & _
" AND ((tblWarehouseLocations.WLocation_ID)=" & lookupValue & "))"
I solved the problem. I created a SELECT query to get the present amount in WQuantity. Now quantityReceived = Me!txtQntyRecd + the present amount. With SET tblWarehouseLocations.WQuantity = " & quantityReceived it works fine. However, if just seems so cumbersome.
' lookupValue gives the index into the tblWarehouseLocations where WQuantity resides
Dim lookupValue As Integer
lookupValue = DLookup("[WLocation_ID]", "[tblWarehouseLocations]", "[Location_Name] = '" & Me.cboWLocation & "'")
'Define SQL Query
strSQL = "select tblWarehouseLocations.WQuantity FROM tblWarehouseLocations WHERE (((tblWarehouseLocations.WLocation_ID)= " & lookupValue & "))"
Set rs = db.OpenRecordset(strSQL)
If IsNull(rs!WQuantity) Then
dbvalue = 0
Else
dbvalue = rs!WQuantity
End If
Dim quantityReceived As Integer
quantityReceived = Val(Me!txtQntyRecd) + dbvalue
updateQnty = "UPDATE tblSupplySources INNER JOIN ((tblWarehouseLocations " & _
"INNER JOIN tblSupplySource_WarehouseLocation ON tblWarehouseLocations.WLocation_ID = tblSupplySource_WarehouseLocation.SWLocation_ID)) " & _
"ON tblSupplySources.SupplySourceID = tblSupplySource_WarehouseLocation.Supply_Source_ID " & _
"SET tblWarehouseLocations.WQuantity = " & quantityReceived & _
" WHERE (((tblSupplySource_WarehouseLocation.Supply_Source_ID)= " & Me.cboSupplySource & ") " & _
" AND ((tblWarehouseLocations.WLocation_ID)=" & lookupValue & "))"
CurrentDb.Execute updateQnty, dbFailOnError
I have a macro that pulls from an Access DB and writes the recordset to the spreadsheet based upon dates that are entered into a userform. However, if I enter in "3/2/2105" and "3/5/2015" it returns all the records from 3/2-3/5 and then 3/20-3/31. I cannot think of any reason why it would do this. If anybody could point me in the right direction/make suggestions it would be greatly appreciated.
Sub pullfrommsaccess()
queryform.Show
Dim conn As Object
Dim rs As Object
Dim AccessFile As String
Dim SQL As String
Dim startdate As String
Dim enddate As String
Dim i As Integer
Sheet2.Cells.Delete
Application.ScreenUpdating = False
AccessFile = ThisWorkbook.Path & "\" & "mdidatabase.accdb"
On Error Resume Next
Set conn = CreateObject("ADODB.connection")
If Err.Number <> 0 Then
MsgBox "Connection was not created!", vbCritical, "Connection Error"
Exit Sub
End If
On Error GoTo 0
conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & AccessFile
If tblname = "Attainments" Then
If shift1 = "1" Then
SQL = "SELECT [Line],[Area],[Shift],[Attainment Percentage],[Date] FROM " & tblname & " WHERE Shift='1' and Date Between " & "'" & pastdate & "' " & "and" & " '" & currentdate & "'"
End If
If shift2 = "2" Then
SQL = "SELECT [Line],[Area],[Shift],[Attainment Percentage],[Date] FROM " & tblname & " WHERE Shift='2' and Date Between " & "'" & pastdate & "' " & "and" & " '" & currentdate & "'"
End If
If shift1 = "1" And shift2 = "2" Then
SQL = "SELECT [Line],[Area],[Shift],[Attainment Percentage],[Date] FROM " & tblname & " WHERE Date Between " & "'" & pastdate & "' " & "and" & " '" & currentdate & "'"
End If
End If
If tblname = "MDItable" Then
If shift1misses = "1" Then
SQL = "SELECT [Date],[Area],[Shift],[Line],[Quantity],[Issue] FROM " & tblname & " WHERE Shift='1' and Date Between " & "'" & pastdatemisses & "' " & "and" & " '" & currentdatemisses & "'"
End If
If shift2misses = "2" Then
SQL = "SELECT [Date],[Area],[Shift],[Line],[Quantity],[Issue] FROM " & tblname & " WHERE Shift='2' and Date Between " & "'" & pastdatemisses & "' " & "and" & " '" & currentdatemisses & "'"
End If
If shift1misses = "1" And shift2misses = "2" Then
SQL = "SELECT [Date],[Area],[Shift],[Line],[Quantity],[Issue] FROM " & tblname & " WHERE Date Between " & "'" & pastdatemisses & "' " & "and" & " '" & currentdatemisses & "'"
End If
End If
On Error Resume Next
Set rs = CreateObject("ADODB.Recordset")
If Err.Number <> 0 Then
Set rs = Nothing
Set conn = Nothing
MsgBox "Recordset was not created!", vbCritical, "Recordset Error"
Exit Sub
End If
On Error GoTo 0
rs.CursorLocation = 3
rs.CursorType = 1
rs.Open SQL, conn
If rs.EOF And rs.BOF Then
rs.Close
conn.Close
Set rs = Nothing
Set conn = Nothing
Application.ScreenUpdating = True
MsgBox "There are no records in the recordset!", vbCritical, "No Records"
Exit Sub
End If
For i = 0 To rs.Fields.Count - 1
Sheet2.Cells(1, i + 1) = rs.Fields(i).Name
Next i
'Copy From RecordSet to Excel and Reset
Sheet2.Range("A2").CopyFromRecordset rs
rs.Close
conn.Close
Set rs = Nothing
Set conn = Nothing
MsgBox "The records from " & pastdate & " and " & currentdate & " were successfully retrieved from the '" & tblname & "' table!", vbInformation, "Done"
End If
Call TrimALL
End Sub
You have a field named Date, try renaming that and reworking the code as in first instance that's a reserved word and is a bad idea for starters!
When working with dates, see Allen Browne's comments on the matter here for consistency;
http://allenbrowne.com/ser-36.html
You have your dates declared as string, but in your SQL query you're surrounding them with a ' not a #. It should read;
Date Between " & "#" & pastdate & "# " & "and" & " #" & currentdate & "#"
All of the above should sort you out, if not comment and I'll take a much closer look for you!