Private Sub Form_Close()
Dim sSQL, stringSQL As String
Dim rst As DAO.Recordset
sSQL = "SELECT BarCode, [Goods Name] FROM tblInventory WHERE BarCode='" & Me.ID & "'"
Set rst = CurrentDb.OpenRecordset(sSQL)
If rst.EOF Then
stringSQL = "INSERT INTO tblInventory(BarCode,[Goods Name],Unit,[Unit Price],[Initial Stock],[Current Stock],[Exit Item]) values('" & Me.ID & "','" & Me.Description & "','" & Me.Unit & "'," & Replace(Format(Me.Price, "0.00"), ",", ".") & "," & Me.Amount & "," & Me.Amount & ",0)"
DoCmd.SetWarnings False
DoCmd.RunSQL (stringSQL) /this is where it is erroring out/
DoCmd.SetWarnings True
Else
stringSQL = "UPDATE tblInventory SET [Current Stock]=[Current Stock]+" & Me.Amount & " WHERE BarCode='" & Me.ID & "'"
DoCmd.SetWarnings False
DoCmd.RunSQL (stringSQL)
DoCmd.SetWarnings True
End If
rst.Close
End Sub
Private Sub ID_AfterUpdate()
Dim sSQL As String
Dim rst As DAO.Recordset
sSQL = "SELECT BarCode, [Goods Name], Unit, [Unit Price] FROM tblInventory WHERE BarCode='" & Me.ID & "'"
Set rst = CurrentDb.OpenRecordset(sSQL)
If rst.EOF Then
MsgBox "New Parts"
Me.Description.SetFocus
Else
Me.Description = rst(1).Value
Me.Unit = rst(2).Value
Me.Price = rst(3).Value
Me.Amount.SetFocus
End If
rst.Close
End Sub
The above errors out where indicated above when i run the insert to table it has error on the doCmd.RunSql (StringSQL) so not sure what i am doing wrong
Related
Please verify the below code which was build to find unmatched values between two table in MS access ( as there is run-time error 3075 in query expression Count(table1.Inv_No])'
Public Sub subCreateRowDiff()
Dim strSQL As String
Dim rs1 As DAO.Recordset
Dim rs2 As DAO.Recordset
Dim db As DAO.Database
Dim lngCount As Long
Const TEMP_TABLE As String = "tblNoMatch"
strSQL = "SELECT table1.[Inv_No], table1.[Amt], Count(table1.Inv_No]) As Expr1 GROUP BY table1.[Inv_No], table1.[Amt];"
Set db = CurrentDb
'remove all records
db.Execute "DELETE " & TEMP_TABLE & ".* FROM " & TEMP_TABLE & ";"
'open table1
Set rs1 = db.OpenRecordset(strSQL)
strSQL = Replace(strSQL, "table1", "table2")
'open table2
Set rs2 = db.OpenRecordset(strSQL)
'check for difference
With rs1
If Not (.BOF And .EOF) Then .MoveFirst
While Not .EOF
lngCount = .Fields(2).Value 'the count field
'find matching record in table2
rs2.FindFirst "[Inv_No] = " & .Fields(0) & " AND [Amt] = " & .Fields(1).Value
If rs2.NoMatch Then
'save this record as many times (lngCount)
While lngCount <> 0
db.Execute "Insert Into " & TEMP_TABLE & "(Inv_No, Amt) " & _
"Values(" & .Fields(0).Value & ", " & .Fields(1) & ");"
lngCount = lngCount - 1
Wend
Else
' there is a match
' check the difference
If .Fields(2).Value > rs2.Fields(2).Value Then
lngCount = .Fields(2).Value - rs2.Fields(2).Value
Else
lngCount = rs2.Fields(2).Value - .Fields(2).Value
End If
While lngCount <> 0
db.Execute "Insert Into " & TEMP_TABLE & "(Inv_No, Amt) " & _
"Values(" & .Fields(0).Value & ", " & .Fields(1) & ");"
lngCount = lngCount - 1
Wend
End If
.MoveNext
Wend
End With
' now use table2 as reference
With rs2
If Not (.BOF And .EOF) Then .MoveFirst
While Not .EOF
lngCount = .Fields(2).Value 'the count field
'find matching record in table1
rs1.FindFirst "[Inv_No] = " & .Fields(0) & " AND [Amt] = " & .Fields(1).Value
If rs1.NoMatch Then
'save this record as many times (lngCount)
While lngCount <> 0
db.Execute "Insert Into " & TEMP_TABLE & "(Inv_No, Amt) " & _
"Values(" & .Fields(0).Value & ", " & .Fields(1) & ");"
lngCount = lngCount - 1
Wend
Else
' we already did this before
' so no need
End If
.MoveNext
Wend
End With
rs1.Close: Set rs1 = Nothing
rs2.Close: Set rs2 = Nothing
Set db = Nothing
End Sub
Missing a left bracket [. No brackets are needed in this SQL statement because table and field names do not have spaces.
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.
I am trying to use the value from a combo box to select which field will be searched when the text box is updated.
This code works but only allows for searching on PatientID:
Private Sub txtGoTo_AfterUpdate()
If (txtGoTo & vbNullString) = vbNullString Then Exit Sub
Dim rs As DAO.Recordset
Set rs = Me.RecordsetClone
rs.FindFirst "[PatientID] =" & txtGoTo
If rs.NoMatch Then
MsgBox "Sorry, no such record '" & txtGoTo & "' was found.", _
vbOKOnly + vbInformation
Else
Me.Recordset.Bookmark = rs.Bookmark
End If
rs.Close
txtGoTo = Null
End Sub
This code DOES NOT work but should convey what I am trying to do (changes bold):
Private Sub txtGoTo_AfterUpdate()
**GCriteria = cboSearchField.Value & " LIKE '*" & txtSearchString & "*'"**
If (txtGoTo & vbNullString) = vbNullString Then Exit Sub
Dim rs As DAO.Recordset
Set rs = Me.RecordsetClone
rs.FindFirst "[**Gcriteria**] =" & txtGoTo
If rs.NoMatch Then
MsgBox "Sorry, no such record '" & txtGoTo & "' was found.", _
vbOKOnly + vbInformation
Else
Me.Recordset.Bookmark = rs.Bookmark
End If
rs.Close
txtGoTo = Null
End Sub
I think it should be just that change from:
rs.FindFirst "[**Gcriteria**] =" & txtGoTo
To:
rs.FindFirst Gcriteria
As you have already set the condition before:
*GCriteria = cboSearchField.Value & " LIKE '*" & txtSearchString & "*'"**
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 ;)