VBA SQL query result error - sql

There's no result or blank excel sheet in result of following SQL query. It works fine if I remove where condition but Its required. So kindly help me to correct my code with where condition. Code is follow-
Private Sub cmdOpenQuery_Click()
Dim strTableName As String
Dim strFieldName As String
Dim strFieldValue As String
Dim strFV As String
Dim strFieldType As String
Dim strBaseSQL As String
Dim strCriteria As String
Dim varItem As Variant
Dim strSQL As String
Dim qdf As DAO.QueryDef
Dim OutPut As String
Dim intCounter As Integer
Dim xlApp As Object
For Each qdf In CurrentDb.QueryDefs
If qdf.Name = "MyQry" Then
DoCmd.DeleteObject acQuery, "MyQry"
Exit For
End If
Next
strTableName = Me.[cboSelectTblQry]
strFieldName = Me.[cboWhere]
strFV = Me.[cboEqualto]
strFieldType = CurrentDb.TableDefs(Me.cboSelectTblQry).Fields(Me.cboWhere).Type
If strFieldType = 4 Then
strFieldValue = "[" & strFV & "]"
ElseIf strFieldType = 10 Then
strFieldValue = "['" & strFV & "']"
ElseIf strFieldType = 8 Then
strFieldValue = "[#" & strFV & "#]"
End If
strBaseSQL = "SELECT "
For intCounter = 0 To lstSelectTo.ListCount
lstSelectTo.Selected(intCounter) = True
Next intCounter
For Each varItem In Me![lstSelectTo].ItemsSelected
strCriteria = strCriteria & "[" & Me![lstSelectTo].ItemData(varItem) & "],"
Next
strSQL = strBaseSQL & Left$(strCriteria, Len(strCriteria) - 1) & " FROM [" & strTableName & "]" & " Where [" & strFieldName & "] = strFieldValue "
Set qdf = CurrentDb.CreateQueryDef("MyQry", strSQL)
If cboFormat = "Excel" Then
OutPut = "D:/Export_" & strTableName & "_" & Date & ".xlsx"
DoCmd.TransferSpreadsheet acExport, , "MyQry", OutPut
MsgBox " File has been exported to " & OutPut
DoCmd.Close
DoCmd.OpenForm "frmCreateQry"
Set xlApp = CreateObject("Excel.Application")
xlApp.Workbooks.Open (OutPut)
xlApp.Visible = True
ElseIf cboFormat = "PDF" Then
OutPut = "D:/Export_" & strTableName & "_" & Date & ".pdf"
DoCmd.OutputTo acOutputQuery, "MyQry", acFormatPDF, OutPut, True
MsgBox " File has been exported to " & OutPut
ElseIf cboFormat = "Word" Then
End If
ExitSub:
Exit Sub
ErrorHandler:
Resume ExitSub
End Sub

Your where condition is using strFieldValue as the value to look for. You should instead use the use held by strFieldValue for comparison. You're doing that properly with strTableName already. It is the same idea here. You'd need to enclose the value of strFieldValue in quotes when you add it.
strSQL = strBaseSQL & Left$(strCriteria, Len(strCriteria) - 1) & " FROM [" & strTableName & "]" & " Where [" & strFieldName & "] = '" & strFieldValue & "'"

I made some corrections and it's working now fine for all format like numeric, text and date type.
Following corrections made in Type condition :-
If strFieldType = 4 Then
strFieldValue = Me.cboEqualto
ElseIf strFieldType = 10 Then
strFieldValue = "'" & strFV & "'"
ElseIf strFieldType = 8 Then
strFieldValue = "#" & strFV & "#"
End If
and following correction in strSQL:-
strSQL = strBaseSQL & Left$(strCriteria, Len(strCriteria) - 1) & " FROM [" & strTableName & "]" & " Where [" & strFieldName & "] = " & strFieldValue & ""

Related

Updating SQL Table via VBA cuts off decimals

I need to update a set of values from an Excel Worksheet into a SQL Server Table.
This is the Excel Table:
I wrote some code in VBA to do this, but I'm not very expert.
The update work just fine except for the part where it truncate decimals.
As you can see the decimals get cuts off. The fields on SQL are declared as Decimal (19,5).
Sure there's something wrong in the VBA code. Here's my code.
On Error GoTo RigaErrore
Dim cn_ADO As Object
Dim cmd_ADO As Object
Dim SQLUser As String
Dim SQLPassword As String
Dim SQLServer As String
Dim DBName As String
Dim DBConn As String
Dim SQLQuery As String
Dim strWhere As String
Dim i As Integer
Dim jOffset As Integer
Dim iStartRow As Integer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'iStep = 100
jOffset = 20
iStartRow = 3
i = iStartRow
SQLUser = "xxxx"
SQLPassword = "xxx"
SQLServer = "xxxxxxxx"
DBName = "xxxxx"
DBConn = "Provider=SQLOLEDB.1;Pesist Security Info=True;User ID=" & SQLUser & ";Password=" & SQLPassword & ";Initial Catalog=" & DBName & ";" & _
"Data Source=" & SQLServer & ";DataTypeCompatibility=80;"
Set cn_ADO = CreateObject("ADODB.Connection")
cn_ADO.Open DBConn
Set cmd_ADO = CreateObject("ADODB.Command")
While Cells(i, jOffset).Value <> ""
xlsIDKey = Cells(i, 0 + jOffset)
xlsVendSim = CDbl(Cells(i, 1 + jOffset))
xlsOreSim = CDbl(Cells(i, 2 + jOffset))
xlsProdVar = CDbl(Cells(i, 3 + jOffset))
xlsOreSimVar = CDbl(Cells(i, 4 + jOffset))
strWhere = "ID_KEY = '" & xlsIDKey & "'"
SQLQuery = "UPDATE DatiSimulati " & _
"SET " & _
"VEND_SIM = Cast(('" & xlsVendSim & "') as decimal (19,5)), " & _
"ORE_SIM = Cast(('" & xlsOreSim & "') as decimal (19,5)), " & _
"PROD_VAR = Cast(('" & xlsProdVar & "') as decimal (19,5)), " & _
"ORE_SIM_VAR = Cast(('" & xlsOreSimVar & "') as decimal (19,5)) " & _
"WHERE " & strWhere
cmd_ADO.CommandText = SQLQuery
cmd_ADO.ActiveConnection = cn_ADO
cmd_ADO.Execute
i = i + 1
Wend
Set cmd_ADO = Nothing
Set cn_ADO = Nothing
Exit Sub
RigaErrore:
MsgBox Err.Number & vbNewLine & Err.Description
Application.StatusBar = False
Application.Cursor = xlDefault
If Not cn_ADO Is Nothing Then
Set cn_ADO = Nothing
End If
If Not cmd_ADO Is Nothing Then
Set cmd_ADO = Nothing
End If
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Thanks everybody who could help solve this.
A work-around would be to replace the decimal commas with dots.
Option Explicit
Sub connectDB()
Const SQLUser = "#"
Const SQLPassword = "#"
Const SQLServer = "#"
Const DBName = "#"
Dim DBConn As String
DBConn = "Provider=SQLOLEDB.1;Pesist Security Info=True" & _
";User ID=" & SQLUser & ";Password=" & SQLPassword & _
";Initial Catalog=" & DBName & _
";Data Source=" & SQLServer & _
";DataTypeCompatibility=80;"
Dim cn_ADO As Object, cmd_ADO As Object
Set cn_ADO = CreateObject("ADODB.Connection")
cn_ADO.Open DBConn
Set cmd_ADO = CreateObject("ADODB.Command")
cmd_ADO.ActiveConnection = cn_ADO
Const joffset = 20
Const iStartRow = 3
Dim SQLQuery As String, sIDKey As String
Dim sVendSim As String, sOreSim As String
Dim sProdVar As String, sOreSimVar As String
Dim i As Long
i = iStartRow
' create log file
Dim LOGFILE As String
LOGFILE = ThisWorkbook.Path & "\logfile.txt"
Dim fs As Object, ts As Object
Set fs = CreateObject("Scripting.FileSystemObject")
Set ts = fs.CreateTextFile(LOGFILE, True)
While Len(Cells(i, joffset).Value) > 0
sIDKey = Cells(i, 0 + joffset)
sVendSim = Replace(Cells(i, 1 + joffset), ",", ".")
sOreSim = Replace(Cells(i, 2 + joffset), ",", ".")
sProdVar = Replace(Cells(i, 3 + joffset), ",", ".")
sOreSimVar = Replace(Cells(i, 4 + joffset), ",", ".")
SQLQuery = "UPDATE DatiSimulati " & _
"SET " & _
"VEND_SIM = " & sVendSim & ", " & _
"ORE_SIM = " & sOreSim & ", " & _
"PROD_VAR = " & sProdVar & ", " & _
"ORE_SIM_VAR = " & sOreSimVar & " " & _
"WHERE ID_KEY = " & sIDKey
ts.writeline SQLQuery & vbCr
cmd_ADO.CommandText = SQLQuery
cmd_ADO.Execute
i = i + 1
Wend
ts.Close
MsgBox i - iStartRow & " records updated see " & LOGFILE, vbInformation
End Sub

MS Access if statement on click event

I am using Ms Access forms and I have created an on click event that locates a folder location but now I want to locate the folder location based on different criteria but when I add the if statement it expects a sub,function or property. Below is some demo code. I really hope someone can explain what is missing?
Private Sub Open_Email_Click()
Dim stAppName As String
Dim stAppNameA As String
Dim stAppNameB As String
stAppName = "C:\Windows\explorer.exe C:\DEMO\TEST\" & Me.Office & " DEMO\B " & Me.BC & " " & Me.UC & "\"
stAppNameA = "C:\Windows\explorer.exe C:\DEMO\TEST\" & Me.Office & " DEMO\A\B " & Me.BC & " " & Me.UC & "\"
stAppNameB = "C:\Windows\explorer.exe C:\DEMO\TEST\" & Me.Office & " DEMO\B\B " & Me.BC & " " & Me.UC & "\"
If (Me.BC = "60") And Me.UC Like "REF123*" Then stAppNameA
ElseIf (Me.BC = "60") And Not Me.UC Like "REF123*" Then stAppNameB
Else: stAppName
End If
Call Shell(stAppName, 1)
End Sub
I think the logic of your function could be reduced to the following, which may be more readable with fewer repeating expressions:
Private Sub Open_Email_Click()
Dim strTmp As String
If Me.BC = "60" Then
If Me.UC Like "REF123*" Then
strTmp = " DEMO\A\B "
Else
strTmp = " DEMO\B\B "
End If
Else
strTmp = " DEMO\B "
End If
Call Shell("C:\Windows\explorer.exe C:\DEMO\TEST\" & Me.Office & strTmp & Me.BC & " " & Me.UC & "\", 1)
End Sub
Alternatively, using a Select Case statement:
Private Sub Open_Email_Click()
Dim strTmp As String
Select Case True
Case Me.BC <> "60"
strTmp = " DEMO\B "
Case Me.UC Like "REF123*"
strTmp = " DEMO\A\B "
Case Else
strTmp = " DEMO\B\B "
End Select
Call Shell("C:\Windows\explorer.exe C:\DEMO\TEST\" & Me.Office & strTmp & Me.BC & " " & Me.UC & "\", 1)
End Sub
To test the resulting path, change:
Call Shell("C:\Windows\explorer.exe C:\DEMO\TEST\" & Me.Office & strTmp & Me.BC & " " & Me.UC & "\", 1)
To:
Debug.Print "C:\Windows\explorer.exe C:\DEMO\TEST\" & Me.Office & strTmp & Me.BC & " " & Me.UC & "\"
I think your If block is just a bit messy in terms of where you have newlines, and continuation characters (:). Try reformatting your code like this:
If (Me.BC = "60") And Me.UC Like "REF123*" Then
stAppName =stAppNameA
ElseIf (Me.BC = "60") And Not Me.UC Like "REF123*" Then
stAppName = stAppNameB
Else
stAppName =stAppName
End If
Call Shell(stAppName, 1)

Can I convert my query to use select .. like .. or?

Can the query in the code below be converted to Select / Like / Or ?
Private Sub cmdQDef_Click()
Dim qd As DAO.QueryDef, db As DAO.Database
Dim ssql As String, WhereName As String, WhereTitle As String
Set db = CurrentDb
If Me.FilterName & "" = "" Then
DoCmd.OpenQuery "q_Search_qdef"
Exit Sub
Else
End If
ssql = "Select * From Employees"
Set qd = db.QueryDefs("q_Search_qdef")
WhereName = "'" & Replace(Me.FilterName, ",", "','") & "'"
WhereTitle = "'" & Replace(Me.FilterTitle, ",", "','") & "'"
ssql = ssql & " Where [First name] In(" & WhereName & ")AND " & _
"[Job Title] In (" & WhereTitle & ")"
qd.SQL = ssql
DoCmd.OpenQuery "q_Search_qdef"
End Sub
Yes:
WhereName = "'*" & Replace(Me.FilterName, ",", "','") & "*'"
WhereTitle = "'" & Replace(Me.FilterTitle, ",", "','") & "'"
ssql = ssql & " Where ([First name] Like " & WhereName & ") OR " & _
"([Job Title] In (" & WhereTitle & ")"

Excel VBA Selecting Records from Access Database Not Pulling Correctly

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!

Access Export Query to Spreadsheet subject to variable conditions?

I have a form with a button, 2 combo boxes as filters, and 3 combo boxes to sort. This button successfully opens a report (trndOTRpt, whose data comes from the query trndOTQry) subject to any criteria that may be chosen and sorted by any sort criteria that may be chosen. I changed the command to instead export the driving query, trndOTQry:
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, _
"trndOTQry", _
"\\es3.com\dfsroot$\YK_Share\office_public\D2S\D2S\D2S_Scorecard\OTTest.xls"
This works successfully. But now I want to apply the same VBA code to filter/sort this query as I did with the report. Here is the whole of it:
(The meat & potatoes is at the bottom, notice the commented out code from the original script to open the report. I simply subbed that for the above TransferSpreadsheet action.)
Private Sub SupervisorsGo_Click()
Dim strWhereCondition As String
Dim strSupervisor As String
Dim strPosition As String
Dim varItem As Variant
For Each varItem In Me.SupervisorCombo.ItemsSelected
strSupervisor = strSupervisor & ",'" & Me.SupervisorCombo.ItemData(varItem) _
& "'"
Next varItem
If Len(strSupervisor) = 0 Then
strSupervisor = "Like '*'"
Else
strSupervisor = Right(strSupervisor, Len(strSupervisor) - 1)
strSupervisor = "IN(" & strSupervisor & ")"
End If
For Each varItem In Me.PositionCombo.ItemsSelected
strPosition = strPosition & ",'" & Me.PositionCombo.ItemData(varItem) _
& "'"
Next varItem
If Len(strPosition) = 0 Then
strPosition = "Like '*'"
Else
strPosition = Right(strPosition, Len(strPosition) - 1)
strPosition = "IN(" & strPosition & ")"
End If
strWhereCondition = "[supervisor] " & strSupervisor & _
" AND [position] " & strPosition
If Me.cboSortOrder1.Value <> "Not Sorted" Then
strSortOrder = "[" & Me.cboSortOrder1.Value & "]"
If Me.cmdSortDirection1.Caption = "Descending" Then
strSortOrder = strSortOrder & " DESC"
End If
If Me.cboSortOrder2.Value <> "Not Sorted" Then
strSortOrder = strSortOrder & ",[" & Me.cboSortOrder2.Value & "]"
If Me.cmdSortDirection2.Caption = "Descending" Then
strSortOrder = strSortOrder & " DESC"
End If
If Me.cboSortOrder3.Value <> "Not Sorted" Then
strSortOrder = strSortOrder & ",[" & Me.cboSortOrder3.Value & "]"
If Me.cmdSortDirection3.Caption = "Descending" Then
strSortOrder = strSortOrder & " DESC"
End If
End If
End If
End If
Debug.Print strWhereCondition
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, _
"trndOTQry", _
"\\es3.com\dfsroot$\YK_Share\office_public\D2S\D2S\D2S_Scorecard\OTTest.xls"
' DoCmd.OpenReport "trndOTRpt", View:=acViewPreview, _
' WhereCondition:=strWhereCondition
With Queries![trndOTQry]
.OrderBy = strSortOrder
.OrderByOn = True
End With
End Sub
This fails. While the original code went With Reports![trndOTRpt], I get Run-time Error 424: Object Required with With Queries![trndOTQry] highlighted. I feel like I have adjusted all references appropriately--why is it not acknowledging the object here?
My goal is to export trndOTQry subject to filters/sorts chosen in the form.