I am having and issue using update batch. I have a loop that goes through a recordset updating values. I have a minimum of 333 things in the batch. When it gets to the 254th item it bails. is there a limit to a batch.
On Error GoTo Err_cmdProcessAll
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim strTableName As String
Dim strSql As String
'
Set cn = New ADODB.Connection
cn.Open "Provider=sqloledb; " & _
"Data Source=" & "BLD-FS-SQLVS04\PRDINST4" & ";" & _
"Initial Catalog=" & "HNFS_NetProv" & ";" & _
"Integrated Security=SSPI;"
cn.CursorLocation = adUseServer
Dim strSortField As String
Dim additionalwhere As String
If cboValue = "pc3Claims" Then
strTableName = "Seq3_PendedClaims_Ranked"
strSortField = "DaysSinceReceivedClaim"
' additionalwhere = " AND (member_eligibility_ud Not Like '%Program%')
strSql = "Select * " & _
"FROM " & strTableName & _
" WHERE (Complete Is Null) And (AssignedTo Is Null)" & additionalwhere & _
" ORDER BY cast( " & strSortField & " as int )" & strSort
ElseIf cboValue = "pc3ContractAssignments" Then
strSortField = "date"
additionalwhere = ""
strSql = "Select * " & _
"FROM " & strTableName & _
" WHERE (Complete Is Null) And (AssignedTo Is Null)" & additionalwhere & _
" ORDER BY CONVERT(varchar(10), CONVERT(datetime, [" & strSortField & "], 111), 121) " & strSort
End If
Set rs = New ADODB.Recordset
With rs
Set .ActiveConnection = cn
.Source = strSql
.LockType = adLockOptimistic
.CursorType = adOpenKeyset
.CursorLocation = adUseClient
.Open
End With
'make change to above to include
Dim i As Long
Dim j As Long
Dim strAssignAssociate As String
Dim lngAllocAmt As Long
For i = 1 To ListView6.ListItems.Count
If ListView6.ListItems(i).Checked Then
strAssignAssociate = ListView6.ListItems(i).SubItems(1)
Debug.Print strAssignAssociate
lngAllocAmt = ListView6.ListItems(i).Text
For j = 1 To lngAllocAmt
Debug.Print rs.Fields("AssignedTo")
rs.Fields("AssignedTo") = strAssignAssociate
Debug.Print rs.Fields("AssignedTo")
rs.MoveNext
Next j
End If
Next i
rs.UpdateBatch
MsgBox "All Finished", vbOKOnly, "Inventory Control"
Set rs = Nothing
Set cn = Nothing
I found the problem. I am using a non-keyed file. I found that I had duplicates in the file. this has been rectified and the above code works fine.
Related
I have a vba that can send out multiple emails to vendors, but I would like to change it so it embeds the query and only sends one email per vendor. Here is what I have so far:
Option Compare Database
Public Sub SendFollowUpEmail()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim emailTo As String
Dim emailSubject As String
Dim emailText As String
Dim outApp As Outlook.Application
Dim outMail As Outlook.MailItem
Dim outlookStarted As Boolean
On Error Resume Next
Set outApp = GetObject(, "Outlook.Application")
On Error GoTo 0
If outApp Is Nothing Then
Set outApp = CreateObject("Outlook.Application")
outlookStarted = True
End If
Set db = CurrentDb
strSQL = "SELECT qry002UnmatchedOpenInvoices.kyUnique, qry002UnmatchedOpenInvoices.[Vendor Nbr],qry002UnmatchedOpenInvoices.[Vendor Name], " & _
" qry002UnmatchedOpenInvoices.[Purchasing Document], qry002UnmatchedOpenInvoices.Item,qry002UnmatchedOpenInvoices.[Document Date], " & _
" qry002UnmatchedOpenInvoices.Material, qry002UnmatchedOpenInvoices.[Short Text],qry002UnmatchedOpenInvoices.[Material Group], " & _
" qry002UnmatchedOpenInvoices.[Invoice Sent], qry002UnmatchedOpenInvoices.[Order Quantity],qry002UnmatchedOpenInvoices.[Order Unit], " & _
" qry002UnmatchedOpenInvoices.[Quantity in SKU], qry002UnmatchedOpenInvoices.[Stockkeeping unit],qry002UnmatchedOpenInvoices.[Net price], " & _
" qry002UnmatchedOpenInvoices.Currency, qry002UnmatchedOpenInvoices.[Price Unit],qry002UnmatchedOpenInvoices.[Release status], " & _
" qry002UnmatchedOpenInvoices.[No of Positions], tblVendors.Vendor, tblVendors.Email " & _
" FROM qry002UnmatchedOpenInvoices LEFT JOIN tblVendors ON qry002UnmatchedOpenInvoices.[Vendor Nbr] =tblVendors.[Vendor Number] " & _
" WHERE (((qry002UnmatchedOpenInvoices.Material) Is Null) AND ((qry002UnmatchedOpenInvoices.[Invoice Sent]) Is Null));"
Set rs = db.OpenRecordset(strSQL, dbOpenDynaset)
Do Until rs.EOF
emailTo = Trim(rs.Fields("Email").Value & "; tom.nguyen#flocorp.com;mike.huston#flocorp.com")
emailSubject = "Open Invoices"
emailText = Trim("Please send invoices of the below Purchase Orders:") & vbCrLf
emailText = emailText & _
"PO# " & rs.Fields("[Purchasing Document]").Value
Set outMail = outApp.CreateItem(olMailItem)
outMail.To = emailTo
outMail.Subject = emailSubject
outMail.Body = emailText
outMail.Send
'rs.Edit
'rs("FUP_Date_Sent") = Now()
rs.MoveNext
Loop
rs.Close
Set rs = Nothing
Set db = Nothing
If outlookStarted Then
outApp.Quit
End If
Set outMail = Nothing
Set outApp = Nothing
End Sub
What you need to do is to use two recordsets. The first selects the distinct vendors, and the second selects the invoices for that vendor. Something like:
Sub sSendFollowUpEMail()
On Error GoTo E_Handle
Dim db As DAO.Database
Dim rsVendor As DAO.Recordset
Dim rsInvoice As DAO.Recordset
Dim objOL As New Outlook.Application
Dim objMail As Outlook.MailItem
Dim strSQL As String
Dim emailTo As String
Dim emailText As String
Set db = CurrentDb
strSQL = "SELECT DISTINCT V.[Vendor Number], V.EMail " _
& " FROM qry002UnmatchedOpenInvoices AS I LEFT JOIN tblVendors AS V ON I.[Vendor Nbr]=V.[Vendor Number] " _
& " WHERE I.Material IS NULL " _
& " AND I.[Invoice Sent] IS NULL;"
Set rsVendor = db.OpenRecordset(strSQL)
If Not (rsVendor.BOF And rsVendor.EOF) Then
Do
strSQL = "SELECT I.[Purchasing Document] " _
& " FROM qry2002UnMatchedOpenInvoices AS I " _
& " WHERE I.Material IS NULL " _
& " AND I.[Invoice Sent] IS NULL " _
& " AND I.[Vendor Nbr]=" & rsVendor("Vendor Number") _
& " ORDER BY I.[Purchasing Document] ASC;"
Set rsInvoice = db.OpenRecordset(strSQL)
If Not (rsInvoice.BOF And rsInvoice.EOF) Then
emailText = "Please pay:"
Do
emailText = emailText & vbCrLf & rsInvoice("Purchasing Document")
rsInvoice.MoveNext
Loop Until rsInvoice.EOF
End If
emailTo = rsVendor!EMail
Set objMail = objOL.CreateItem(olMailItem)
objMail.To = emailTo
objMail.Subject = EmailSubject
objMail.Body = emailText
objMail.Send
rsVendor.MoveNext
Loop Until rsVendor.EOF
End If
sExit:
On Error Resume Next
rsVendor.Close
rsInvoice.Close
Set rsVendor = Nothing
Set rsInvoice = Nothing
Set db = Nothing
Set objMail = Nothing
objOL.Quit
Set objOL = Nothing
Exit Sub
E_Handle:
MsgBox Err.Description & vbCrLf & vbcrfl & "sSendFollowUpEMail", vbOKOnly + vbCritical, "Error: " & Err.Number
Resume sExit
End Sub
A few notes.
In your original recordset you were including a whole load of fields that were not used in this procedure, which is not recommended - only get data that you need as this will enhance performance;
Secondly, it appears that you are mixing early and late binding of Outlook;
Finally, I've used aliases for the query/table names in the SQL statements - this makes the SQL more manageable, and also if you need to change one of the original tables/queries it is a lot easier to change the name just once.
Regards,
Sub Get_Data()
Dim conn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim dateVar As Date
Set conn = New ADODB.Connection
conn.ConnectionString = "DRIVER={MySQL ODBC 5.1 Driver}; SERVER=localhost; DATABASE=bi; UID=username; PWD=password; OPTION=3"
conn.Open
strSQL = " SELECT " & _
" Products " & _
" FROM Logistics " & _
" WHERE DATE(insert_timestamp) = ""2020-02-24"" " & _
" GROUP BY 1"
Set rs = New ADODB.Recordset
rs.Open strSQL, conn, adOpenStatic
Sheet5.Range("A1").CopyFromRecordset rs
rs.Close
conn.Close
End Sub
I run the above VBA to extract values fom the database.
It works exactly how I need it.
Now, instead of having a pre-defined date within strSQL I want to use the data that is entered into Cell B1 in my Excel spreadsheet. Therefore, I changed the strSQL part in the VBA to:
strSQL = " SELECT " & _
" Products " & _
" FROM Logistics " & _
" WHERE DATE(insert_timestamp) = " & Sheet1.Range("B1") & " " & _
" GROUP BY 1"
However, now I get runtime error -2147217887 (80040e21) on rs.Open strSQL, conn, adOpenStatic.
What do I need to change in my VBA to make it work?
Consider the industry best practice of SQL parameterization using the ADO Command object which can properly handle data types without string concatenation or various formatting:
Dim conn As ADODB.Connection ' REMOVE New INITIALIZATION IN Dim LINES
Dim rs As ADODB.Recordset
Dim cmd As ADODB.Command
Dim dateVar As Date
Set conn = New ADODB.Connection
conn.ConnectionString = "DRIVER={MySQL ODBC 5.1 Driver}; ..."
conn.Open
' STRING STATEMENT WITH QMARK PLACEHOLDER
strSQL = " SELECT " & _
" Products " & _
" FROM Logistics " & _
" WHERE DATE(insert_timestamp) = ?" & _
" GROUP BY Products"
' CONVERT CELL TO DATE TYPE (IF CELL FORMATTED AS STRING)
dateVar = CDate(Sheet1.Range("B1").Value)
Set cmd = New ADODB.Command
With cmd
.ActiveConnection = conn
.CommandText = strSQL
.CommandType = adCmdText
' BIND PARAMS TO QMARK POSITIONAL PLACEHOLDER
.Parameters.Append .CreateParameter("mydate", adDate, adParamInput, , dateVar)
' PASS RESULT TO RECORDSET
Set rs = .Execute
End With
Sheet5.Range("A1").CopyFromRecordset rs
Try:
strSQL = " SELECT " & _
" Products " & _
" FROM Logistics " & _
" WHERE DATE(insert_timestamp) = '" & Format(Sheet1.Range("B1").Value, "YYYY-MM-DD") & "' " & _
" GROUP BY 1"
Just be aware, if insert_timestamp does indeed contain a time other than midnight, you might not get the results you're after without converting to just a date or altering your SQL.
Okay, I need help resolving what should be an easy issue. I am trying to do an UPDATE query to an Access table. I have the ID of the record to be updated in a hidden text box on my form. What happens is that the query def changes my Integer to a string when it stores it in the parameter. It does this even after I cast the value to an Integer. p6 is the parameter name. See code below. I get a data type mismatch error on every other field that has an integer value as well.
Private Sub SubmitButton_Click()
Dim db As DAO.Database
Dim qdf As DAO.QueryDef
Dim strSql As String
Dim frm As Object
If IsRequiredFilled(Me) = False Then
MsgBox "Please fill out all required fields.", vbCritical
Exit Sub
End If
Set db = CurrentDb
strSql = "UPDATE [Batches_T] " & _
"SET [BatchName] = [BatchName] + [p1], " & _
"[StatusID] = [StatusID] + [p2], " & _
"[InternalStatusID] = [InternalStatusID] + [p2], " & _
"[ReviewerID] = [ReviewerID] + [p3], " & _
"[StartDate] = [StartDate] + [p4], " & _
"[PowerPointFilePath] = [PowerPointFilePath] + [p5] " & _
"WHERE [ID] = [p6]"
Set qdf = db.CreateQueryDef(vbNullString, strSql)
With qdf
.Parameters("p1").Value = Me.BatchName
.Parameters("p2").Value = Me.StatusID
.Parameters("p3").Value = Me.InternalStatusID
.Parameters("p4").Value = Me.StartDate
.Parameters("p5").Value = Me.PowerPointFilePath
.Parameters("p6").Value = CInt(Me.ID)
.Execute dbFailOnError
End With
Set qdf = Nothing
Set db = Nothing
Forms![Dashboard_F]![Batches_DS_F].Requery
If Me.keepOpenCheckBox = False Then
DoCmd.Close acForm, "AddBatch_F", acSaveYes
End If
End Sub
Try and add explicit type declarations for the parameter:
strSql = "PARAMETERS [p6] INTEGER; " & _
"UPDATE [Batches_T] " & _
"SET [BatchName] = [BatchName] + [p1], " & _
"[StatusID] = [StatusID] + [p2], " & _
"[InternalStatusID] = [InternalStatusID] + [p2], " & _
"[ReviewerID] = [ReviewerID] + [p3], " & _
"[StartDate] = [StartDate] + [p4], " & _
"[PowerPointFilePath] = [PowerPointFilePath] + [p5] " & _
"WHERE [ID] = [p6]"
This is my complete code. I was able to run the code once and get the record sets export to excel, but I can't do a different operation the second time.
It looks like after the record set is closed once, its not opening again. When I search second time it giving me the above error 3704.
Basically I have a form with three text boxes to search the database and then export the record sets to excel.
I might be missing something simple as I am not an experienced programmer.
Option Compare Database
Private Sub search_Click()
Dim cn As Object
Dim rs As ADODB.Recordset
Dim strSql As String
Dim strConnection As String
Dim xlApp As Object
Dim xlWb As Object
Dim xlWs As Object
Set cn = CreateObject("ADODB.Connection")
Set rs = New ADODB.Recordset
strConnection = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=C:\Users\e3017764\Desktop\Master.accdb"
cn.Open strConnection
If (skill.Value = "" And location.Value = "" And project.Value = "") Then
MsgBox "Please Enter Atleast one criteria"
ElseIf (skill.Value <> "" And location.Value = "" And project.Value = "") Then
strSql = "SELECT [Ecode/LC Code],[Resource Name],Project,Location FROM [Resource Details] WHERE [Primary Skills] = '" & skill.Value & "'"
rs.Open strSql, CurrentProject.Connection, adOpenStatic, adLockOptimistic
ElseIf (skill.Value = "" And location.Value = "" And project.Value <> "") Then
strSql = "SELECT [Ecode/LC Code],[Resource Name],Project,Location FROM [Resource Details] WHERE Project = '" & project.Value & "'"
rs.Open strSql, CurrentProject.Connection, adOpenStatic, adLockOptimistic
ElseIf (skill.Value = "" And location.Value <> "" And project.Value = "") Then
strSql = "SELECT [Ecode/LC Code],[Resource Name],Project,Location FROM [Resource Details] WHERE Location = '" & location.Value & "'"
rs.Open strSql, CurrentProject.Connection, adOpenStatic, adLockOptimistic
ElseIf (skill.Value <> "" And project.Value <> "" And location.Value = "") Then
strSql = "SELECT [Ecode/LC Code],[Resource Name],Project,Location FROM [Resource Details] WHERE [Primary Skills] = '" & skill.Value & "' AND Project = '" & project.Value & "'"
rs.Open strSql, CurrentProject.Connection, adOpenStatic, adLockOptimistic
ElseIf (skill.Value <> "" And project.Value = "" And location.Value <> "") Then
strSql = "SELECT [Ecode/LC Code],[Resource Name],Project,Location FROM [Resource Details] WHERE [Primary Skills] = '" & skill.Value & "' AND Location = '" & location.Value & "'"
rs.Open strSql, CurrentProject.Connection, adOpenStatic, adLockOptimistic
ElseIf (skill.Value = "" And project.Value <> "" And location.Value <> "") Then
strSql = "SELECT [Ecode/LC Code],[Resource Name],Project,Location FROM [Resource Details] WHERE Project = '" & project.Value & "' AND Location = '" & location.Value & "'"
rs.Open strSql, CurrentProject.Connection, adOpenStatic, adLockOptimistic
ElseIf (skill.Value <> "" And project.Value <> "" And location.Value <> "") Then
rs.Open
strSql = "SELECT [Ecode/LC Code],[Resource Name],Project,Location FROM [Resource Details] WHERE [Primary Skills] = '" & skill.Value & "' AND Project = '" & project.Value & "' AND Location = '" & location.Value & "'"
rs.Open strSql, CurrentProject.Connection, adOpenStatic, adLockOptimistic
End If
MsgBox " Total Records Matched " & rs.RecordCount
Set xlApp = CreateObject("Excel.Application")
Set xlWb = xlApp.Workbooks.Add
Set xlWs = xlWb.Worksheets("Sheet1")
xlApp.Visible = True
xlApp.UserControl = True
xlWs.Cells(1, 1).Value = "E Code"
xlWs.Cells(1, 2).Value = "Name"
xlWs.Cells(1, 3).Value = "Project"
xlWs.Cells(1, 4).Value = "Location"
xlWs.Cells(2, 1).CopyFromRecordset rs
xlApp.Selection.CurrentRegion.Columns.AutoFit
xlApp.Selection.CurrentRegion.Rows.AutoFit
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
End Sub
I agree with #Sobigen that none of your IFs are true the second time around. Maybe. Anyway, I think if you simplify the IFs, you might see the answer more quickly. Here's a rewrite to consider
Private Sub search_Click()
Dim rs As ADODB.Recordset
Dim sSql As String
Dim aWhere() As String
Dim lWhereCnt As Long
Dim xlApp As Object
Dim xlWs As Object
'This never changes, so make it a constant
Const sSELECT As String = "SELECT [Ecode/LC Code],[Resource Name],Project,Location FROM [Resource Details] WHERE "
'put each piece of your where clause in an array
If Len(Me.skill.Value) > 0 Then
lWhereCnt = lWhereCnt + 1
ReDim Preserve aWhere(1 To lWhereCnt)
aWhere(lWhereCnt) = "[Primary Skills] = '" & Me.skill.Value & "'"
End If
If Len(Me.location.Value) > 0 Then
lWhereCnt = lWhereCnt + 1
ReDim Preserve aWhere(1 To lWhereCnt)
aWhere(lWhereCnt) = "[Location] = '" & Me.location.Value & "'"
End If
If Len(Me.project.Value) > 0 Then
lWhereCnt = lWhereCnt + 1
ReDim Preserve aWhere(1 To lWhereCnt)
aWhere(lWhereCnt) = "[Project] = '" & Me.project.Value & "'"
End If
'If there's at least one criterion
If lWhereCnt > 0 Then
'build the sql and execute it
sSql = sSELECT & Join(aWhere, " And ") & ";"
Set rs = CurrentProject.Connection.Execute(sSql)
'if at least one record is returned put it in excel
If Not rs.BOF And Not rs.EOF Then
Set xlApp = CreateObject("Excel.Application")
Set xlWs = xlApp.Workbooks.Add.worksheets(1)
xlApp.Visible = True
xlApp.UserControl = True
xlWs.Cells(1, 1).Resize(1, 4).Value = Split("E Code,Name,Project,Location", ",")
xlWs.Cells(2, 1).CopyFromRecordset rs
xlApp.Selection.CurrentRegion.Columns.AutoFit
xlApp.Selection.CurrentRegion.Rows.AutoFit
rs.Close
Set rs = Nothing
Else
'if no records are return, take a look at the sql statement to see why
MsgBox sSql
End If
Else
MsgBox "Please Enter Atleast one criteria"
End If
End Sub
I need your help. I woulod like to change one char by another but in all database and i have several table and fields. So i'm building a function in VB but that change nothing and i have no error. I think that my condition is false but i don't see how to correct it :/
Public Sub updateField()
Dim db As DAO.Database, td As DAO.TableDef, field As DAO.field
Dim rs As DAO.Recordset, sSQL As String, sData As String
Set db = CurrentDb
Change = "\"""
replaced = """"
'each table in db
For Each tbd In db.TableDefs
'each field in table
For Each fld In tbd.Fields
'check if String Data have my character
If InStr(1, fld.Name, Change) Then
sSQL = "UPDATE " & tbd.Name & " SET " & fld.Name & " = replace([" & fld.Name & "], " & Change & ", " & replaced & ")"
db.Execute sSQL
End If
Next
Next
End Sub
EDIT :
I finally find what's wrong. if some people are interested :
Set db = CurrentDb
Change = "\"""
replaced = """"
'each table in db
For Each tbd In db.TableDefs
'each field in table
For Each fld In tbd.Fields
If Left(tbd.Name, 4) <> "MSys" And Left(tbd.Name, 4) <> "~TMP" Then
If fld.Type = dbText Or fld.Type = dbMemo Then
sSQL = "UPDATE " & tbd.Name & " SET " & fld.Name & " = replace([" & fld.Name & "],'" & Chr(92) + Chr(34) & "','" & Chr(34) & "')"
db.Execute sSQL
'Debug.Print (sSQL)
End If
End If
Next
Next
Thx for your help guys ;)
If it should help there my solution :
Public Sub updateField()
Dim db As DAO.Database, td As DAO.TableDef, field As DAO.field
Dim rs As DAO.Recordset, sSQL As String, sData As String, change As String, replace As String
change = "\'"
replace = "'"
' simple quote = 39
' doulbe quote = 34
' antislash = 92
' retour chariot = 13
' n = 110
' r = 114
Set db = CurrentDb
'each table in db
For Each tbd In db.TableDefs
'each field in table
For Each fld In tbd.Fields
If Left(tbd.Name, 4) <> "MSys" And Left(tbd.Name, 4) <> "~TMP" Then
If fld.Type = dbText Or fld.Type = dbMemo Then
' \r\n
'sSQL = "UPDATE " & tbd.Name & " SET [" & fld.Name & "] = replace([" & fld.Name & "],'\r\n','" & Chr(13) & Chr(10) & "');"
' \"
'sSQL = "UPDATE " & tbd.Name & " SET [" & fld.Name & "] = replace([" & fld.Name & "],'" & Chr(92) + Chr(34) & "','" & Chr(34) & "');"
'db.Execute sSQL
sSQL = "UPDATE " & tbd.Name & " SET [" & fld.Name & "] = replace([" & fld.Name & "],'\''','''');"
db.Execute sSQL
'Debug.Print (sSQL)
End If
End If
Next
Next
End Sub
That's works for me ;)