I would like to run the IF, ELSE statement below on a SQL query run from a connection between Excel and Access using VBA. Any idea why this won't work?
Dim myValue As String
myValue = "CS-SS-22"
Set cn = New ADODB.Connection
cn.Open "Provider=Microsoft.ACE.OLEDB.12.0; " & _
"Data Source=Q:\TOC Contract Screenings\ScreeningLogDatabase.accdb"
Set rs = New ADODB.Recordset
If rs.Open("Select count([ChangeScreeningNumber]) From [ScreeningLogsTEST] Where [ChangeScreeningNumber] = '" & myValue & "'", ActiveConnection:=cn, CursorType:=adOpenDynamic, LockType:=adLockOptimistic) = 0 Then MsgBox "New"
Else
MsgBox "Already exists"
Not quite sure what you are after, but it could be something like this:
Set rs = New ADODB.Recordset
rs.Open "Select Count([ChangeScreeningNumber]) From [ScreeningLogsTEST] Where [ChangeScreeningNumber] = '" & myValue & "'", ActiveConnection:=cn, CursorType:=adOpenDynamic, LockType:=adLockOptimistic
If rs.RecordCount = 0 Then
MsgBox "New"
Else
MsgBox "Already exists"
End If
Related
Can we use SQL command to delete multiple records in a big excel file in excel vba.
Try it and see if you get
Option Explicit
Sub TestDelete()
Dim con As ADODB.Connection, cmd As ADODB.Command
Dim sCon As String, n As Long
sCon = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & ThisWorkbook.FullName & _
";Extended Properties='Excel 12.0 Macro;HDR=YES';"
' sheet1
With Sheet1
.Cells.Clear
.Cells(1, 1) = "A"
.Cells(1, 2) = "B"
For n = 2 To 20
.Cells(n, 1) = n
.Cells(n, 2) = 0
Next
End With
' connect
Set con = New ADODB.Connection
con.Open sCon
' command
Set cmd = New ADODB.Command
With cmd
.ActiveConnection = con
.CommandType = adCmdText
End With
' select
cmd.CommandText = "SELECT [A] FROM [Sheet1$]"
MsgBox cmd.Execute(n).GetString, vbInformation, cmd.CommandText
' update
cmd.CommandText = "UPDATE [Sheet1$] SET [B]=[A]+10"
cmd.Execute n
MsgBox n & " records updated", vbInformation, cmd.CommandText
' delete
cmd.CommandText = "DELETE FROM [Sheet1$] WHERE [B] > 20"
On Error Resume Next
cmd.Execute n
If Err.Number <> 0 Then
MsgBox Err.Description, vbInformation, cmd.CommandText
Else
MsgBox n & " records deleted", vbInformation, cmd.CommandText
End If
End Sub
I am unable to execute a simple sql statement. - sorry I am sure this is simple and I am missing something small. Error says missing the object.
dbPath = "C:\Users\User\Documents\test0419.accdb"
tblName = "Wait_Data_Table"
strcon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & dbPath & "';"
conn.Open strcon
Set wrkSpaceNew = DBEngine.CreateWorkspace("Check", "admin", "", dbUseJet)
rcdDetail = ("SELECT order.ord_id, order.job_id, order.bc_desc, order.ord_amount, order.ord_diff FROM Order")
Set rs = DBEngine.BeginTrans(rcdDetail)
You can use either DAO or ADODB, not normally both. See difference-between-ado-and-dao
Option Explicit
Sub UseDAO()
Const SQL = " SELECT order.ord_id, order.job_id, order.bc_desc, " & _
" order.ord_amount, order.ord_diff " & _
" FROM [Order]"
Const dbpath = "C:\Users\User\Documents\test0419.accdb"
Dim wkspace As workspace, db As DAO.Database, rs As DAO.Recordset
Set wkspace = DBEngine.CreateWorkspace("Check", "admin", "", dbUseJet)
Set db = wkspace.OpenDatabase(dbpath)
Set rs = db.OpenRecordset(SQL)
Sheet1.Range("A1").CopyFromRecordset rs
db.Close
Set db = Nothing
wkspace.Close
Set wkspace = Nothing
MsgBox "Results on sheet " & Sheet1.Name, vbInformation, "DAO"
End Sub
Sub UseADODB()
Const SQL = " SELECT order.ord_id, order.job_id, order.bc_desc, " & _
" order.ord_amount, order.ord_diff " & _
" FROM [Order]"
Const dbpath = "C:\Users\User\Documents\test0419.accdb"
Dim strConn As String, conn As ADODB.Connection, rs As ADODB.Recordset
strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & dbpath & "';"
Set conn = New ADODB.Connection
conn.Open strConn
Set rs = conn.Execute(SQL)
Sheet1.Range("A1").CopyFromRecordset rs
conn.Close
MsgBox "Results on sheet " & Sheet1.Name, vbInformation, "ADODB"
End Sub
Don't forget to add Activex Data Object in Reference Section
Dim baglanti As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim sunucu, veritabani, id, sifre, sorgu As String
sunucu = "DESKTOP-GF32DLC\SQLEXPRESS"
veritabani = "AdventureWorks2014"
id = ""
sifre = ""
sorgu = "SELECT * FROM [HumanResources].[Department] Where [GroupName]='Manufacturing'"
baglanti.Open "Driver={SQL SERVER};Server=" & sunucu & ";Database=" & veritabani & _
";Uid=" & id & ";Pwd=" & sifre & ";"
rs.Open sorgu, baglanti, adOpenStatic
With Range("A1:AA1000")
.ClearContents
.CopyFromRecordset rs
End With
rs.Close
baglanti.Close
This way you can make a healthy sql connection.
I used to use it to connect sql in the past
I am putting in place a code for that acts as a time clock. I want to make a "smart" time clock where I store time in/out in different columns. To do that, I have set up a logic that:
1. Updates the "time_in" column when the user has not clocked in yet for the day
2. Updates the "Break Out" column when the "Time in" is not empty and the "Break Out" is empty
3. Updates the "Break In" column when both "Time in" and "Break Out" columns are not empty but "Break In" is
4.Updates the "Time Out" column whenever all the previous column are not empty but "Time Out" column is
I don't know if this is the best to achieve my goal, but that's the logic I am trying to implement.
To achieve this, I found no other solution but to have multiple recordset open for my connection, each one checking for the conditions above but I am getting so many errors that I don't even know where they are coming from. Sometimes the code works fine till the end the field is updated in the Access table, sometimes I get errors like 'Either EOF or BOF is empty...' or "Operation not allowed in this context" when getting to the update statement
Here is the code:
`Private Sub CommandButton1_Click()
Dim conn As Object
Dim rs As Object
Dim rs2 As Object
Dim rs3 As Object
Dim rs4 As Object
Dim rs5 As Object
Dim rs6 As Object
Dim strconn As String
Dim qry As String
Dim sql As String
Dim extrct As String
Dim extrct2 As String
Dim extrct3 As String
Dim extrct4 As String
Dim BadgeId As String
Set conn = CreateObject("ADODB.connection")
Set rs = CreateObject("ADODB.Recordset")
Set rs2 = CreateObject("ADODB.Recordset")
Set rs3 = CreateObject("ADODB.Recordset")
Set rs4 = CreateObject("ADODB.Recordset")
Set rs5 = CreateObject("ADODB.Recordset")
Set rs6 = CreateObject("ADODB.Recordset")
strconn = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data source = [Path]"
qry = "select * from pointage"
sql = "select * from employes where actif='Yes' and matricule=" & Val(POINTAGE.PointMatricule)
extrct = "select * from pointage where matricule=" & Me.PointMatricule & " " & "and fix(date_prestation)= Date()"
extrct2 = "select * from pointage where matricule=" & Me.PointMatricule & " and fix(date_prestation)= Date()" & " and pause_out is null"
extrct3 = "select * from pointage where matricule=" & Me.PointMatricule & " and fix(date_prestation)= Date()" & " and pause_out is not null" & " and pause_in is null"
extrct4 = "select * from pointage where matricule=" & Me.PointMatricule & " and fix(date_prestation)= Date()" & " and pause_out is not null" & " and pause_in is not null" & " and heure_out is null"
conn.Open (strconn)
rs.Open qry, conn, adOpenKeyset, adLockOptimistic, adCmdText
rs2.Open sql, conn, adOpenKeyset, adLockOptimistic, adCmdText
rs3.Open extrct, conn, adOpenKeyset, adLockOptimistic, adCmdText
rs4.Open extrct2, conn, adOpenKeyset, adLockOptimistic, adCmdText
rs5.Open extrct3, conn, adOpenKeyset, adLockOptimistic, adCmdText
rs6.Open extrct4, conn, adOpenKeyset, adLockOptimistic, adCmdText
If rs3.EOF And rs3.BOF Then
With rs
.AddNew
.Fields("matricule").Value = Me.PointMatricule
.Fields("date_prestation").Value = Format(Date, "dd/mm/yyyy")
.Fields("heure_in").Value = Format(Time, "hh:mm:ss")
End With
GoTo 3
ElseIf Not (rs4.EOF And rs4.BOF) Then
With rs4
.Fields("pause_out").Value = Format(Time, "hh:mm:ss") 'Error: Either EOF or BOF...
End With
ElseIf Not (rs5.EOF And rs5.BOF) Then
With rs5
.Fields("pause_in").Value = Format(Time, "hh:mm:ss")
End With
ElseIf Not (rs6.EOF And rs6.BOF) Then
With rs6
.Fields("pause_out").Value = Format(Time, "hh:mm:ss")
End With
end if
rs.Update
rs.Close
Set rs = Nothing
rs2.Close
Set rs2 = Nothing
rs3.Close
Set rs3 = Nothing ' From here on is where I get errors: Not allowed...
rs4.Close
Set rs4 = Nothing
rs5.Close
Set rs5 = Nothing
rs6.Close
Set rs6 = Nothing
conn.Close
Set conn = Nothing
end sub`
Can someone please me better this code? Or maybe there is a better way to approach this...
PS: There are some words in french, sorry. Translation: Pause: Break. Heure: Hour. Matricule: Unique ID
Untested (and assuming your SQL is correct) but you could probably do it this way with a single recordset:
Private Sub CommandButton1_Click()
Dim conn As Object
Dim rs As Object
Dim strconn As String
Dim extrct As String, tm
Set conn = CreateObject("ADODB.connection")
strconn = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data source = [Path]"
conn.Open strconn
Set rs = CreateObject("ADODB.Recordset")
extrct = "select * from pointage where matricule=" & Me.PointMatricule & _
" and fix(date_prestation)= Date()"
tm = Format(Time, "hh:mm:ss")
rs.Open extrct, conn, adOpenKeyset, adLockOptimistic, adCmdText
With rs
If .EOF Then
'no entry yet for today...
.AddNew
.Fields("matricule").Value = Me.PointMatricule
.Fields("date_prestation").Value = Date ' Format(Date, "dd/mm/yyyy")
.Fields("heure_in").Value = tm
Else
'have an entry for today - figure out which field to update
If IsNull(.Fields("pause_out")) Then
.Fields("pause_out").Value = tm
ElseIf IsNull(.Fields("pause_in")) Then
.Fields("pause_in").Value = tm
ElseIf IsNull(.Fields("heure_out")) Then
.Fields("heure_out").Value = tm
End If
End If
.Update 'save changes
.Close
End With
conn.Close
Set conn = Nothing
End Sub
I'm trying to use DCount to see if records exist in a table before inserting the data into the database but I keep getting a type mismatch error on "Customer Number" and have no idea why. The code is below:
Public Sub ExportData()
Set cn = CreateObject("ADODB.Connection")
dbPath = Application.ActiveWorkbook.Path & "\PRID.mdb"
dbWb = Application.ActiveWorkbook.FullName
dbWs = Application.ActiveSheet.Name
scn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & dbPath
dsh = "[" & Application.ActiveSheet.Name & "$]"
cn.Open scn
ssql = "INSERT INTO [Investment Data] ([Customer Number])"
ssql = ssql & "SELECT [Customer Number] FROM [Excel 8.0;HDR=YES;DATABASE=" & dbWb & "]." & dsh
If Application.WorksheetFunction.DCount("Customer Number", "Investment Data", "[Customer Number]=" & Range("A2")) > 0 Then
MsgBox ("A similar entry has been detected within the PRID database, please make sure that this is a new entry before you continue.")
Else
MsgBox ("Entry has been entered into the database.")
cn.Execute ssql
Exit Sub
End If
Any help would be appreciated thanks.
This should resolve your problem
You can add a WHERE clause to your query that will skip the [Customer Number] that already exists in the [Investment Data] table.
ssql = ssql & _
" WHERE [Customer Number] NOT IN(SELECT [Customer Number] FROM [Investment Data]);)"
You can then use Connection.Execute to return the number of records added.
Results = cN.Execute(ssql)
MsgBox Results & " Records were added " & (allRecordsCount - Results) & "Records Were Skipped"
If you want to alert the user before you insert the records you'll need two queries.
ssql = ssql & "SELECT [Customer Number] FROM [Excel 8.0;HDR=YES;DATABASE=" & dbWb & "]." & dsh & _
ssql & " WHERE [Customer Number] IN(SELECT [Customer Number] FROM [Investment Data]);)"
Set rs = CreateObject("ADODB.Recordset")
Set rs = cN.Execute(ssql)
If Not rs.BOF AND Not rs.EOF Then
msg = msg & vbCrLf & rs.Fields("Customer Number").Value
rs.MoveNext
End If
If msg <> "" Then
MsgBox "These Records Are Duplicates" & vbCrLf & msg
Exit Sub
End If
This should answer your question
You are getting the "DCount Type Mismatch Error VBA" because you are trying to query an external Access Database using the Excel WorksheetFunction DCount.
Test Queries
Public Sub TestQueries()
Set cN = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
dbPath = Application.ActiveWorkbook.path & "\PRID.mdb"
'dbPath = "C:\Users\best buy\Downloads\stackoverfow\Sample Data File\test.mdb"
dbWb = Application.ActiveWorkbook.FullName
dbWs = Application.ActiveSheet.Name
scn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & dbPath
dsh = "[" & Application.ActiveSheet.Name & "$]"
cN.Open scn
ssql = ssql & "SELECT [Customer Number] FROM [Excel 8.0;HDR=YES;DATABASE=" & dbWb & "]." & dsh
Set rs = cN.Execute(ssql)
Do While Not rs.BOF And Not rs.EOF
msg = msg & vbCrLf & rs.FIelds(0).Value
rs.MoveNext
Loop
MsgBox msg, vbInformation, "Results Query Without Where Clause"
ssql = ssql & _
" WHERE [Customer Number] IN(SELECT CDbl([Customer Number]) FROM [Investment Data])"
msg = ""
Set rs = cN.Execute(ssql)
Do While Not rs.BOF And Not rs.EOF
msg = msg & vbCrLf & rs.FIelds(0).Value
rs.MoveNext
Loop
MsgBox msg, vbInformation, "Results Query With Where Clause"
End Sub
I am trying to extract the data with ADODB connection through VBA but when i run throgh this code recset.Open strSQL, con, adOpenKeyset, adLockOptimistic
my excel is automatically getting closed.
Is there anything which i am missing?
Sub Show_data()
Dim con As ADODB.Connection
Dim recset As ADODB.Recordset
Dim ConnectionString As String
Dim strSQL As String
Set con = New ADODB.Connection
Set recset = New ADODB.Recordset
'Check for the connectivity or connected to the xx network
On Error GoTo errHandler
errHandler:
If Err.Number = -2147467259 Then
MsgBox "Please check for the xx connectivity ", vbExclamation + vbOKOnly
Exit Sub
End If
ConnectionString = "Provider=MSDASQL;User ID=myuser;password= mypass;Data Source=mys"
con.Open ConnectionString
'Set and Excecute SQL Command'
strSQL = "SELECT B.USER_NAME AS CREATED_BY, A.CREATION_DATE, C.USER_NAME, A.LAST_UPDATE_DATE, A.PFIZER_ITEMCODE, A.SYSTEM_ITEMCODE AS ORACLE_ITEM_CODE, " & _
"A.ITEM_DESCRIPTION, A.BATCH_NUMBER, A.MFR_CODE, A.MFR_DESC AS MFR_DESCRIPTION, TO_CHAR(A.MFR_DATE,'DD-MON-YYYY')As MFR_DATE, TO_CHAR(A.EXPIRY_DATE,'DD-MON-YYYY')As EXPIRY_DATE, " & _
"TO_CHAR(A.EFFECTIVE_FROM,'DD-MON-YYYY') AS EFFECTIVE_FROM, " & _
"A.EFFECTIVE_TO, A.EXCISE AS EXCISE_AMOUNT, A.EXCISE_RATE, A.P2S, A.P2R, A.MRP, A.STATE_CODE, A.STATE, " & _
"(CASE SUBSTR(A.SYSTEM_ITEMCODE,6,2) WHEN ('PI') THEN 'OIP' WHEN ('PF') THEN 'OPF' ELSE 'OWL' END )AS LEGAL_ENTITY " & _
"FROM xxdhl_pf_batch_pricing A JOIN fnd_user B ON A.CREATED_BY = B.USER_ID " & _
"JOIN fnd_user C ON A.LAST_UPDATED_BY = C.USER_ID WHERE "
If (ActiveSheet.cmbLE.Text) <> "" Then
strSQL = strSQL & " (CASE SUBSTR(A.SYSTEM_ITEMCODE,6,2) WHEN ('PI') THEN 'OIP' WHEN ('PF') THEN 'OPF' ELSE 'OWL' END )='" & ActiveSheet.cmbLE.Text & "'"
End If
If (ActiveSheet.cmbProduct.Text) <> "" Then
If (ActiveSheet.cmbLE.Text) <> "" Then
strSQL = strSQL & " AND A.SYSTEM_ITEMCODE='" & ActiveSheet.cmbProduct.Text & "'"
Else
strSQL = strSQL & " A.SYSTEM_ITEMCODE='" & ActiveSheet.cmbProduct.Text & "'"
End If
End If
If (ActiveSheet.txtBatch.Text) <> "" Then
If (ActiveSheet.cmbLE.Text) <> "" Or (ActiveSheet.cmbProduct.Text) <> "" Then
strSQL = strSQL & " AND A.BATCH_NUMBER='" & ActiveSheet.txtBatch.Text & "'"
Else
strSQL = strSQL & " A.BATCH_NUMBER='" & ActiveSheet.txtBatch.Text & "'"
End If
End If
'Open Recordset
Set recset.ActiveConnection = con
recset.Open strSQL, con, adOpenKeyset, adLockOptimistic
'Copy the data
If recset.RecordCount > 0 Then
Sheets("Sheet2").Range("A2").CopyFromRecordset recset
Else
MsgBox "No Data Available", vbExclamation + vbOKOnly
Exit Sub
End If
recset.Close
con.Close
End Sub
The issue may be with your connection's cursor location, by default it is adUseServer. When using keyset, you will probably want to use adUseClient. I know from using ms access that this is especially the case when attempting to bind the recordset to a form. Try opening the connection with adUseClient, hopefully it will resolve your issue.