I am using the Update query inside VBA to Update one particular column.
But I am getting the Data Mismatch in criteria expression error. Please find below the code.
Public Function UpdateDistinctColumnFRNumberBasis()
MergedInvoiceFile = "\test.xlsx"
StrInvoiceNumber = "010541-01"
FRSparepartNumber = "FT99999000006"
Application.ScreenUpdating = False
Application.Calculation = xlCalculateManual
Application.EnableEvents = False
Dim objConn As Object
Dim objRecordSet As Object
Set objConn = CreateObject("ADODB.Connection")
Set objRecCmd = CreateObject("ADODB.Command")
Set objRecCmd_Update = CreateObject("ADODB.Command")
objConn.Open ("Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & MergedInvoiceFile & ";Extended Properties=""Excel 8.0;""")
strSQL = "Update [Tabelle1$] SET [Distinct] = 'Distinct' Where ([RECHNR] ='" & StrInvoiceNumber & "' AND [TEILENUMMER] = '" & FRSparepartNumber & "')"
objConn.Execute strSQL
objConn.Close
Set objConn = Nothing
Set objRecCmd = Nothing
Set objRecCmd_Update = Nothing
End Function
Related
I don't want to extract 0 values from Excel using the select query in VBA. I have used the below mentioned code for the same and it is working, like if there is 0 values present the code it is ignoring that but if there are no 0 values present in the Excel I am getting an error. So my main motive is if 0 values are present then ignore it using select query and if there are no 0 values in the Excel column then its okay just ignore the null values only.
Dim objConn As Object
Dim objRecordSet As Object
Dim objRecCmd As Object
Set objConn = CreateObject("ADODB.Connection")
Set objRecCmd = CreateObject("ADODB.Command")
Set objRecCmd_Update = CreateObject("ADODB.Command")
strFolderPath = "\inputexcel"
strQuery = "Select [BUNO],[RECHNR] from [Sheet1$] where [RECHNR] ='" & StrInvoiceNumber & "' AND ([AW_NUMMER] Is Not Null And ([AW_NUMMER] <> 0))"
objConn.Open ("Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strFolderPath & ";Extended Properties=""Excel 12.0;IMEX=1""")
'Set objConn.Open = objConn.Execute(Source, Options:=Options)
Set objRecordSet = CreateObject("ADODB.Recordset")
objRecordSet.CursorLocation = adUseClient
objRecCmd.ActiveConnection = objConn
objRecCmd.CommandText = strQuery
objRecordSet.Open objRecCmd, , adOpenKeyset, adLockOptimistic
If Not objRecordSet.BOF And Not objRecordSet.EOF Then
objRecordSet.MoveFirst
End If
Using the test code at the end of this post...
Source table #1 (a null and a zero, no errors - results at right):
Source Table #2 (no zeros, and no errors - results at right)
Source Table #3 (no zeros, but cell C3 has an empty string value, so it's not really null). Gives error Datatype mismatch in query expression because of that one non-null non-numeric value in C3.
Sub TestSO()
Dim objConn As Object
Dim objRecordSet As Object
Dim objRecCmd As Object, strFolderPath, strQuery
Set objConn = CreateObject("ADODB.Connection")
Set objRecCmd = CreateObject("ADODB.Command")
strFolderPath = ThisWorkbook.Path & "\" & ThisWorkbook.Name
objConn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strFolderPath & _
";Extended Properties=""Excel 12.0;IMEX=1"""
strQuery = "Select [BUNO],[RECHNR],[AW_NUMMER] from [Sheet1$] where [RECHNR] ='" & "blah" & _
"' AND ([AW_NUMMER] Is Not Null And ([AW_NUMMER] <> 0))"
Set objRecordSet = CreateObject("ADODB.Recordset")
objRecordSet.CursorLocation = adUseClient
objRecCmd.ActiveConnection = objConn
objRecCmd.CommandText = strQuery
objRecordSet.Open objRecCmd, , adOpenKeyset, adLockOptimistic
[F2].CurrentRegion.ClearContents
If Not objRecordSet.BOF And Not objRecordSet.EOF Then
[F2].CopyFromRecordset objRecordSet '.MoveFirst
End If
End Sub
I am trying to group by and sum specific columns by using SQL queries and copy the result into another work sheet but it's throwing
Run-time error -2147217887 (80040e21): Automation Error
I can't figure out why for whatever reason and throwing error at .Open.
please find the pics of Excel table
Code:
Sub CreateConsolidatedTable()
Const adOpenKeyset = 1
Const adLockOptimistic = 3
Const WORKSHEETNAME As String = "Sheet1"
Const TABLENAME As String = "Table1"
Dim conn As Object, rs As Object
Dim tbl As ListObject
Dim Destination As Range
Set Destination = ThisWorkbook.Worksheets("Sheet2").Range("C1")
Set rg = ThisWorkbook.Worksheets("Sheet1").UsedRange
Set tbl = ThisWorkbook.Worksheets("Sheet1").ListObjects.Add(xlSrcRange, rg, , xlYes)
'Set tbl = Worksheets(WORKSHEETNAME).ListObjects(TABLENAME)
Set conn = CreateObject("ADODB.Connection")
conn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=Yes;IMEX=1"";"
conn.Open
' On Error GoTo CloseConnection
Set rs = CreateObject("ADODB.Recordset")
With rs
.ActiveConnection = conn
.CursorType = adOpenKeyset
.LockType = adLockOptimistic
.Source = getSQL(tbl)
.Open
With Destination
tbl.HeaderRowRange.Copy .Range("c1")
.Range("c2").CopyFromRecordset rs
.Parent.ListObjects.Add SourceType:=xlSrcRange, Source:=.Range("c1").CurrentRegion, XlListObjectHasHeaders:=xlYes, TableStyleName:=tbl.TableStyle
End With
End With
CloseRecordset:
rs.Close
Set rs = Nothing
CloseConnection:
conn.Close
Set conn = Nothing
End Sub
Function getSQL(tbl As ListObject) As String
Dim SQL As String, SheetName As String, RangeAddress As String
SQL = "SELECT DISTINCTROW [DATE_], [ACCOUNT_CODE], Sum([PRINCIPAL_DUE]) AS [Sum Of PRINCIPAL_DUE],[GL_HEAD_CODE_PRINCIPAL], Sum([INTEREST_DUE]) AS [INTEREST_DUE],[INTEREST_RATE]" & _
" FROM [SheetName$RangeAddress]" & _
" GROUP BY [ACCOUNT_CODE], [GL_HEAD_CODE_PRINCIPAL], [DATE_];"
SheetName = tbl.Parent.Name
RangeAddress = tbl.Range.Address(False, False)
Debug.Print SheetName
Debug.Print RangeAddress
SQL = Replace(SQL, "SheetName", SheetName)
SQL = Replace(SQL, "RangeAddress", RangeAddress)
getSQL = SQL
End Function
The following SQL line works fine for me, it groups and sums accordingly.
SQL = "SELECT [DATE_], [ACCOUNT_CODE], Sum([PRINCIPAL_DUE]) AS [Sum Of PRINCIPAL_DUE],[GL_HEAD_CODE_PRINCIPAL], Sum([INTEREST_DUE]) AS [INTEREST_DUE] " & _
" FROM [SheetName$RangeAddress]" & _
" GROUP BY [ACCOUNT_CODE], [GL_HEAD_CODE_PRINCIPAL], [DATE_];"
That's based on my mock-up data. If you're getting the same number of rows output as input, then check that the fields you're grouping by aren't hiding any extra data (like a time-stamp in the date column for instance) that would fragment the grouping.
I am trying to get the data from a SQL database through excel, I am using a ADOB connection. It was working fine and now i get a run time error, do not know what is the cause of it. I have not changed a code. My following code is:
Public Sub SQL_Connection()
Dim con As ADODB.Connection
Dim rs As ADODB.Recordset
Dim StrQuery As String
Set con = New ADODB.Connection
Set rs = New ADODB.Recordset
With ActiveSheet()
.Unprotect Password:=*****
End With
Sheets(2).Range("A2:H2").ClearContents
........
If CheckBox4.Value = True Then
strCon = "Provider=SQLOLEDB;Data Source=******\SQLEXPRESS;" & _
"Initial Catalog=testdata;" & _
"User ID=test;Password=*****;"
End If
........
If CheckBox4.Value = True Then
Const DB_CONNECT_STRING = "Provider=SQLOLEDB;Data Source=******\SQLEXPRESS;Initial Catalog=testdata;user id ='test';password=*****"
Set myConn = CreateObject("ADODB.Connection")
Set myCommand = CreateObject("ADODB.Command")
myConn.ConnectionTimeout = 15
myConn.Open DB_CONNECT_STRING1
Set myCommand.ActiveConnection = myConn
myCommand.CommandText = "UPDATE Rewind SET Cause = '" & Sheets(2).Range("I2") & "' WHERE RewindID = '" & Sheets(2).Range("J2") & "'"
myCommand.Execute
myConn.Close
End If
With ActiveSheet
.Protect Password:=66090
End With
End Sub
Please help.
I want to use the code below to quickly add all network printers from my domain into an Excel spreadsheet to use for my records. The code works fine except for the fact that the PortName (IP Address) is not displayed (cells are blank).
Could someone look over my code bellow and point out why is it not working for the PortName field..
Private Sub GetAllPrintersFromAD()
Const ADS_SCOPE_SUBTREE = 2
Set objRoot = GetObject("LDAP://rootDSE")
strDomain = objRoot.Get("defaultNamingContext")
Set objConnection = CreateObject("ADODB.Connection")
Set objCommand = CreateObject("ADODB.Command")
objConnection.Provider = "ADsDSOObject"
objConnection.Open "Active Directory Provider"
Set objCommand.ActiveConnection = objConnection
objCommand.CommandText = _
"SELECT distinguishedName,portName,location,servername FROM 'LDAP://" & strDomain & "' WHERE objectClass='printQueue'"
objCommand.Properties("Page Size") = 1000
objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE
Set objRecordSet = objCommand.Execute
ActiveSheet.Range("A2").CopyFromRecordset objRecordSet
objRecordSet.Close
objConnection.Close
End Sub
1. Problem: Data types
Your code is not working for a few reasons:
The portName field is stored as DataTypeEnum 12 (Automation Variant: DBTYPE_VARIANT)
DBTYPE_VARIANT is unsupported for usage with ADO (source).
CopyFromRecordset has known data type issues (source)
Note: all other fields are stored as DataTypeEnum 202 (null-terminated Unicode character string).
2. Solution
You will need to iterate through the records and import the portName to a string, then write that string to the correct cell. This ensures that VBA handles the conversion, rather than CopyFromRecordset attempting to determine the (in)correct data type. If you would like to keep your original code with limited modification, I've provided a rudimentary example below.
I was able to duplicate your issue on my machine; the below modified code works as intended and includes the IP.
Private Sub GetAllPrintersFromAD()
Const ADS_SCOPE_SUBTREE = 2
Set objRoot = GetObject("LDAP://rootDSE")
strDomain = objRoot.Get("defaultNamingContext")
Set objConnection = CreateObject("ADODB.Connection")
Set objCommand = CreateObject("ADODB.Command")
objConnection.Provider = "ADsDSOObject"
objConnection.Open "Active Directory Provider"
Set objCommand.ActiveConnection = objConnection
objCommand.CommandText = _
"SELECT distinguishedName,portName,location,servername FROM 'LDAP://" & strDomain & "' WHERE objectClass='printQueue'"
objCommand.Properties("Page Size") = 1000
objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE
Set objRecordSet = objCommand.Execute
ActiveSheet.Range("A2").CopyFromRecordset objRecordSet
'Copy over the portName field properly
objRecordSet.MoveFirst
i = 2
Do Until objRecordSet.EOF
strportname = vbNullString
On Error Resume Next
strportname = objRecordSet.Fields("portName")
Err.Clear
On Error GoTo 0
ActiveSheet.Range("B" & i).Value2 = strportname
i = i + 1
objRecordSet.MoveNext
Loop
objRecordSet.Close
objConnection.Close
End Sub
I use this old script to write same data to .csv file. Works good for me. Give it a try.
'Query AD for Printer details form printer name
ReportLog = "OutPut.csv"
Dim objFSO : Set objFSO = CreateObject("Scripting.FileSystemObject")
Dim objOut : Set objOut = objFSO.CreateTextFile(ReportLog)
objOut.WriteLine "Dis Name;printer name;port name;Location;Server name;"
Set objRootDSE = GetObject("LDAP://rootDSE")
strADsPath = "<LDAP://" & objRootDSE.Get("defaultNamingContext") & ">"
Set objConnection = CreateObject("ADODB.Connection")
Set objCommand = CreateObject("ADODB.Command")
objConnection.Provider = "ADsDSOOBject"
objConnection.Open "Active Directory Provider"
Set objCommand.ActiveConnection = objConnection
strFilter = "(&(objectClass=printQueue))"
strAttributes = "distinguishedName,printShareName,portName,location,servername"
strQuery = strADsPath & ";" & strFilter & ";" & strAttributes & ";subtree"
objCommand.CommandText = strQuery
objCommand.Properties("Page Size") = 1000
objCommand.Properties("Timeout") = 300
objCommand.Properties("Cache Results") = False
Set objRecordSet = objCommand.Execute
'objRecordSet.MoveFirst
Do Until objRecordSet.EOF
strDN = "<ERROR>"
strPSN = "<ERROR>"
strPN = "<ERROR>"
strLO = "<ERROR>"
strSN = "<ERROR>"
On Error Resume Next
strDN = objRecordSet.Fields("distinguishedName")
strPSN = objRecordSet.Fields("printShareName")
strPN = objRecordSet.Fields("portName")
strLO = objRecordSet.Fields("location")
strSN = objRecordSet.Fields("serverName")
Err.Clear
On Error GoTo 0
objOut.WriteLine """" & strDN & """;""" & Join(strPSN, ";") & """;""" & Join(strPN, ";") & """;""" & strLO & """;""" & strSN & """"
objRecordSet.MoveNext
Loop
'Next
objOut.Close
WScript.Echo "Finished"
The output is:
I'm trying to use the below code to take the active cell and update a table in SQL Server.
Sub UpdateTable()
Dim rngName As Range
cnnstr = "Provider=SQLOLEDB; " & _
"Data Source=MyServer; " & _
"Initial Catalog=Mydb;" & _
"User ID=User;" & _
"Password=Pwd;" & _
"Trusted_Connection=No"
Set rngName = ActiveCell
'Debug.Print (rngName)
Set cnn = New ADODB.Connection
Application.ScreenUpdating = False
cnn.Open cnnstr
Set rs = New ADODB.Recordset
uSQL = "UPDATE MyTable SET FieldNameX = 1 WHERE FieldNameY = '" & rngName & "' "
rs.CursorLocation = adUseClient
rs.Open uSQL, cnn, adOpenStatic, adLockOptimistic, adCmdText
rs.Close
Set rs = Nothing
cnn.Close
Set cnn = Nothing
Exit Sub
End Sub
When stepping through the code, it run time errors on the line rs.close, says Operation is not allowed when the object is closed I've set and opened the record set in the code so why would it be closed?
What would I need to do to correct the issue and let the active cell populate the query and update the table in SQL Server?
This below is the code I used to be able to update the table in SQL Server, this works just how I wanted. It takes the activecell and updates.
Sub UpdateTable()
Dim cnn As ADODB.Connection
Dim uSQL As String
Dim rngName As Range
Set cnn = New Connection
cnnstr = "Provider=SQLOLEDB; " & _
"Data Source=MyServer; " & _
"Initial Catalog=Mydb;" & _
"User ID=User;" & _
"Password=Pwd;" & _
"Trusted_Connection=No"
Set rngName = ActiveCell
cnn.Open cnnstr
uSQL = "UPDATE MyTable SET FieldNameX = 1 WHERE FieldNameY= '" & rngName & "' "
'Debug.Print (uSQL)
cnn.Execute uSQL
cnn.Close
Set cnn = Nothing
Exit Sub
End Sub