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
Related
I am working on a reconciliation automation wherein I have to join multiple sheet data to produce an output. When I query single sheet without using joins it works fine, however when I join multiple sheets I get "Run-time error -2147467259 (80004005) Type mismatch in expression"
I am working on: Microsoft 365 MSO (16.0.12827.20236) 64-bit
Here is my code for reference:
Dim con As New ADODB.Connection
Function Open_Connection() As Byte
Dim strFile As String
Dim strCon As String
On Error GoTo Con_Error
strFile = ThisWorkbook.FullName
If Not con Is Nothing Then If con.State = 1 Then con.Close
strCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strFile & ";Extended Properties=""Excel 12.0;HDR=Yes;IMEX=1"";"
con.Open strCon
Open_Connection = 1
Exit Function
Con_Error:
Open_Connection = 0
End Function
Private Function Supplier_Range() As String
Dim LastRow As Long
LastRow = Dump_Supplier.Range("A" & Dump_Supplier.UsedRange.Rows.Count + 1).End(xlUp).Row
If LastRow > 2 Then
Supplier_Range = Dump_Supplier.Name & "$" & Replace(Dump_Supplier.Range("A2:P" & LastRow).Address, "$", "")
End If
End Function
Private Function Client_Range() As String
Dim LastRow As Long
LastRow = Dump_Client.Range("A" & Dump_Client.UsedRange.Rows.Count + 1).End(xlUp).Row
If LastRow > 2 Then
Client_Range = Dump_Client.Name & "$" & Replace(Dump_Client.Range("A2:N" & LastRow).Address, "$", "")
End If
End Function
Function SQL_inv()
Dim Supplier_Range_txt As String
Dim Client_Range_txt As String
Supplier_Range_txt = Supplier_Range
If Len(Supplier_Range_txt) = 0 Then
MsgBox prompt:="No Data Found On " & Dump_Supplier.Name & " Sheet.", Buttons:=vbCritical, Title:="Data Not Found"
Exit Function
End If
Client_Range_txt = Client_Range
If Len(Client_Range_txt) = 0 Then
MsgBox prompt:="No Data Found On " & Dump_Client.Name & " Sheet.", Buttons:=vbCritical, Title:="Data Not Found"
Exit Function
End If
Open_Connection
If con.State = 0 Then
MsgBox prompt:="Connection With Dataset Could Not Be Opened.", Buttons:=vbCritical, Title:="Connection Failure"
Exit Function
End If
Dim strSQL As String
Dim Supplier_Inv As New ADODB.Recordset
Dim Client_Inv As New ADODB.Recordset
Dim Inv_Exact_Match As New ADODB.Recordset
Dim Inv_Match_With_Diff As New ADODB.Recordset
Dim Inv_Match_Amt As New ADODB.Recordset
Dim Inv_No_Match As New ADODB.Recordset
If Not Supplier_Inv Is Nothing Then If Supplier_Inv.State = 1 Then Supplier_Inv.Close
strSQL = "SELECT * FROM [" & Supplier_Range_txt & "] WHERE [Standard Type] LIKE ""%Invoice%"";"
strSQL = "SELECT A.[Pst DT], A.[Year], A.[Month], A.[Standard Type], A.[Type], A.[Invoice / Reference], A.[Amount], A.[Curr], A.[Debit Amount (+)], A.[Credit Amount (-)] FROM [" & Supplier_Range_txt & "] A WHERE [Standard Type] LIKE ""%Invoice%"";"
Supplier_Inv.Open Source:=strSQL, ActiveConnection:=con, CursorType:=adOpenKeyset, LockType:=adLockOptimistic
If Not Client_Inv Is Nothing Then If Client_Inv.State = 1 Then Client_Inv.Close
strSQL = "SELECT * FROM [" & Client_Range_txt & "] WHERE [Standard Type] LIKE ""%Invoice%"";"
strSQL = "SELECT B.[GL Date], B.[Year], B.[Month], B.[Standard Type], B.[Type], B.[Inv Check Num], B.[INR Amount], B.[Currency] FROM [" & Client_Range_txt & "] B WHERE [Standard Type] LIKE ""%Invoice%"";"
Client_Inv.Open Source:=strSQL, ActiveConnection:=con
Stop
If Not Inv_Exact_Match Is Nothing Then If Inv_Exact_Match.State = 1 Then Inv_Exact_Match.Close
strSQL = "SELECT A.[Pst DT], A.[Year], A.[Month], A.[Standard Type], A.[Type], A.[Invoice / Reference], A.[Amount], A.[Curr], A.[Debit Amount (+)], A.[Credit Amount (-)], " & _
"B.[GL Date], B.[Year], B.[Month], B.[Standard Type], B.[Type], B.[Inv Check Num], B.[INR Amount], B.[Currency] " & _
"FROM [" & Supplier_Range_txt & "] A " & _
"INNER JOIN [" & Client_Range_txt & "] B " & _
"ON A.[Invoice / Reference] = B.[Inv Check Num] AND A.[Standard Type] = B.[Standard Type] " & _
"WHERE A.[Standard Type] LIKE ""%Invoice%"" ;"
'AND Abs(Abs(A.[Amount]) - Abs(B.[INR Amount])) <= Home.[Amount_Diff_Tolerance].Value
Debug.Print strSQL
Inv_Exact_Match.Open Source:=strSQL, ActiveConnection:=con, CursorType:=adOpenKeyset, LockType:=adLockOptimistic
'Debug.Print Supplier_Inv.GetString
Debug.Print Inv_Exact_Match.GetString
End Function
Here is what my join query produces:
SELECT A.[Pst DT], A.[Year], A.[Month], A.[Standard Type], A.[Type], A.[Invoice / Reference], A.[Amount], A.[Curr], A.[Debit Amount (+)], A.[Credit Amount (-)], B.[GL Date], B.[Year], B.[Month], B.[Standard Type], B.[Type], B.[Inv Check Num], B.[INR Amount], B.[Currency] FROM [SOA-Supplier$A2:P25581] A INNER JOIN [SOA-Client$A2:N23548] B ON A.[Invoice / Reference] = B.[Inv Check Num] AND A.[Standard Type] = B.[Standard Type] WHERE A.[Standard Type] LIKE "%Invoice%" ;
Any help is appreciated. Thanks!
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'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
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.
I am trying to read the contents of two different tabs in a worksheet and compare them by using ADODB and querying techniques VBA.
Below you can find my code:
stCon = "Provider=Microsoft.Jet.OLEDB.4.0;" _
& "Data Source=" & wbBook.FullName & ";" _
& "Extended Properties=""Excel 8.0;HDR=YES;IMEX=1;Readonly = False"";"
' MsgBox (stCon)
'here is SQL code to gather data including our calculation from two tables within the workbook
'stSQL = "SELECT [Recon_Daily_Xml_report$].RECTYPEGLEDGER, [GL_Activity_totals$].TRXNTYPE, ([Recon_Daily_Xml_report$].Amount_Abs - [GL_Activity_totals$].BILLINGAMT) as Amount_Diff ,"
'stSQL = stSQL & " ([Recon_Daily_Xml_report$].NUMOFENTRIES - [GL_Activity_totals$].NUMOFTRXNS) as Count_Diff "
'stSQL = stSQL & " FROM [Recon_Daily_Xml_report$], [GL_Activity_totals$]"
'stSQL = stSQL & " WHERE Lower([Recon_Daily_Xml_report$].RECTYPEGLEDGER) = Lower([GL_Activity_totals$].TRXNTYPE)"
'stSQL = stSQL & " ORDER BY [Recon_Daily_Xml_report$].RECTYPEGLEDGER ASC"
stSQL = "SELECT LCASE([GL_Activity_totals$].TRXNTYPE),Sum(ABS([GL_Activity_totals$].BILLINGAMT)),Sum([GL_Activity_totals$].NUMOFTRXNS) "
stSQL = stSQL & " FROM [GL_Activity_totals$] "
stSQL = stSQL & " Group By [GL_Activity_totals$].TRXNTYPE "
stSQL = stSQL & " ORDER BY [GL_Activity_totals$].TRXNTYPE ASC"
'MsgBox (stSQL)
Set cnt = New ADODB.Connection
Set rst = New ADODB.Recordset
cnt.Open stCon
'rst.Open stSQL, cnt, 1, 3
rst.Open stSQL, cnt, adOpenStatic, adLockOptimistic
'rst.Open strSQL, cnt, adOpenStatic, adLockOptimistic
With rst
Do While Not .EOF
If rst.Fields.Item(0).Value <> "" Then
strString = Replace(rst.Fields.Item(0).Value, " ", " ")
rst.Update
rst.Fields.Item(0) = strString
End If
.MoveNext
Loop
End With
This specific code gives me back an error suggesting that I cannot update the field in the recordset I want to update when reading it. The error I am currently getting is:
Run-time error '-2147217911 Cannot update. Database or object is read-only.
Tried to change the way i open the recordset by using 1,3 option but again i was getting the same error.
Can anyone help with this?
The issue is with
LCASE([GL_Activity_totals$].TRXNTYPE)
and with the GROUP BY.
In this case, rst.Fields.Item(0) is an expression, not a table value. You can't update expressions. Also, since you're using GROUP BY, the recordset is not linked to any particular record for access to edit. You could accomplish the same task purely in SQL
cnt.Execute("UPDATE [GL_Activity_totals$] " & _
" SET [GL_Activity_totals$].TRXNTYPE = Substitute([GL_Activity_totals$].TRXNTYPE,' ', ' ') " & _
" WHERE NOT [GL_Activity_totals$].TRXNTYPE IS NULL " & _
" AND [GL_Activity_totals$].TRXNTYPE <> '';")