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.
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 using Excel 2013 as a front end application written w/ VBA.
I've linked a XLSX file inside an Access 2013 database in order to use SQL simply for example to read MAX Value of a column of which datas are filtered with a Where Clause.
I cannot understand why a SQL statement for retrieving MAX value does not work whereas the same statement is OK via SQL Querying in Access.
Hereafter VBA code excerpt :
varCnxStr = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" &
G_sWBookREINVOICingFilePath & ";Mode="
With conXLdb
'*
'.Provider = "Microsoft.ACE.OLEDB.12.0"
'.ConnectionString = "Data Source=" & G_sWBookREINVOICingFilePath & ";"
& "Extended Properties='Excel 12.0;HDR = YES'"
'.Mode = adModeShareExclusive
.Open varCnxStr & adModeShareExclusive
'*
End With
Debug.Print varCnxStr & adModeShareExclusive
strSQL = "SELECT MAX(InvoiceNum) as LastNumInvoice"
strSQL = strSQL & " FROM ReInvoiceDB "
strSQL = strSQL & " WHERE InvoiceNum > " & strYMPrefix_p & "000"
strSQL = strSQL & ";"
Debug.Print strSQL
adoXLrst.Open Source:=strSQL, ActiveConnection:=conXLdb,
CursorType:=adOpenStatic, LockType:=adLockOptimistic, Options:=adCmdText
adoXLrst.MoveFirst
'Set adoXLrst = conXLdb.Execute(strSQL)
HighestStr = adoXLrst![LastNumInvoice]
adoXLrst.Close
strGSFNumber = HighestStr '>> byref returning value
conXLdb.Close
Veloma:
'>>
On Error Resume Next
Set adoXLrst = Nothing
Set conXLdb = Nothing
Exit Sub
'>>
Diso:
Beep
Beep
'>>
strGSFNumber = "ERR"
'>>
sMsg = "pG_getNEXTInvoiceValueXLasDB-ERR ::" & Err.Number & ":: - " &
Err.Description
MsgBox sMsg, vbOKOnly + vbCritical
sRet = sMsg
Resume Veloma
End Sub
It returns Null value in variable HighestStr whereas it should receive a double value ...
Any help or any clue on misfunctionning ?
Regards.
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
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'm trying to join two CSV files.
Currently I'm trying to add the following code. I added a validation if the connection was open with the "If Not objConnection Is Nothing Then" but supposedly the connection is open. When I run the code I get the following error message:
which roughly translates to:
An error has occurred '2147217904 (80040e10)' in execution time:
Some required values have not been specified.
I have the following libraries loaded:
The code is as follows:
Dim objConnection As ADODB.Connection
Dim objrecordset As ADODB.Recordset
fNameAndPath = Application.GetOpenFilename(FileFilter:="CSV File (*.csv),(*.csv)", Title:="Select first CSV file")
If fNameAndPath = False Then
Exit Sub
End If
fNameAndPath2 = Application.GetOpenFilename(FileFilter:="CSV File (*.csv),(*.csv)", Title:="Select second CSV file")
If fNameAndPath2 = False Then
Exit Sub
End If
Set objConnection = CreateObject("ADODB.Connection")
Set objrecordset = CreateObject("ADODB.Recordset")
strPath = Left(fNameAndPath, InStrRev(fNameAndPath, "\") - 1)
Filename = Mid(fNameAndPath, InStrRev(fNameAndPath, "\") + 1)
strPath2 = Left(fNameAndPath2, InStrRev(fNameAndPath2, "\") - 1)
Filename2 = Mid(fNameAndPath2, InStrRev(fNameAndPath2, "\") + 1)
With objConnection
.Provider = "Microsoft.Jet.OLEDB.4.0"
.ConnectionString = "Data Source=" & strPath & _
";Extended Properties=""text;HDR=Yes;FMT=Delimited"";"
.Open
End With
strSql = "SELECT * FROM " & Filename & " as file1, " _
& "" & Filename2 & " as file2" _
& " WHERE file1.[APOYO] = file2.[APOYO]"
If Not objConnection Is Nothing Then
If (objConnection.State And adStateOpen) = adStateOpen Then
Set objrecordset = objConnection.Execute(strSql)
End If
End If
Restarted from scratch.
This code works:
Sub leerCSV()
On Error Resume Next
Const adOpenStatic = 3
Const adLockOptimistic = 3
Const adCmdText = &H1
Set objConnection = CreateObject("ADODB.Connection")
Set objRecordset = CreateObject("ADODB.Recordset")
strPathtoTextFile = "C:\"
objConnection.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & strPathtoTextFile & ";" & _
"Extended Properties=""text;HDR=YES;FMT=Delimited"""
strSql = "SELECT * FROM file.csv F1 " _
& " LEFT JOIN file2.csv F2 ON F1.[c1] = F2.[c1] "
objRecordset.Open strSql, objConnection, adOpenStatic, adLockOptimistic, adCmdText
MsgBox "Registros: " & objRecordset.RecordCount
Debug.Print Now
Do Until objRecordset.EOF
Debug.Print "Name: " & objRecordset.Fields.Item("APOYO") & " Department: " & objRecordset.Fields.Item("O&D") & " Extension: " & objRecordset.Fields.Item("FECHA")
objRecordset.MoveNext
Loop
''Tidy up
objRecordset.Close
objConnection.Close
End Sub