VBA function to loop and reduce inventory in Access
The purpose of this function is to look at requirements for a particular item by job in a date descending order, look at the available inventory on hand, and reduce that by the requirements for a job. When the on hand inventory is exhausted, then it needs to check what is sitting in an inspection location, and move the consumption from good to the inspection quantity.
In the event that it runs negative, that is fine at the end, but it can only do that after it has reduced all good, then all inspection.
I have been trying to get some existing code that was in use here to perform this function, but I think I am stuck at this point. I keep getting a Loop without Do message and try as I might, I cannot figure out which of my changes is causing it.
Prior to the Loop without Do error, I was getting the inventory levels to reduce, but only on the Good Inventory portion, the QC/Inspection portion was remaining the same (though I think I was close to fixing that). Any help would be great, because I do not think that I am far off.
Here is the code below. I also attached an Excel file which is the basic idea of what the result would be. Green is the start of normal deductions, Yellow is out of QC, Red is the end of the line. Hopefully this is all clear enough. I will be back online around 9 am (need to finally go to sleep for a few hours).
Dim rst As DAO.Recordset
Dim SQLQuery As String
Dim qty_oh As Double 'asoh
Dim qty_r As Double 'total_qty
Dim new_qoh As Double 'new_usoh
Dim new_qoh_prev As Double 'new_usoh_prev
Dim item_prev As String 'Item_No_Prev
Dim item As String 'Item_No
Dim ord_no As String 'Ord_No
' Dim Ord_Type As String
Dim status As String
Dim start_date As Date
Dim qcqty_oh As Double
Dim qcnew_qoh As Double
Dim qcnew_qoh_prev As Double
Dim new_qtyr As Double
' OpenQuery (2)
Set db = CurrentDb
DBEngine.SetOption dbMaxLocksPerFile, 200000
SQLQuery = "SELECT tbl_order_age.ord_no, tbl_order_age.item, tbl_order_age.qty_oh, tbl_order_age.qty_r, tbl_order_age.new_qoh, tbl_order_age.status, tbl_order_age.ord_no, tbl_order_age.start_date, tbl_order_age.qcqty_oh, tbl_order_age.newqty_r, tbl_order_age.qcnew_qoh FROM tbl_order_age order by tbl_order_age.item, tbl_order_age.status, tbl_order_age.start_date,t
'MsgBox SQLQuery
Set rst = db.OpenRecordset(SQLQuery)
rst.MoveFirst
item_prev = ""
new_qoh_prev = 0
qcnew_qoh_prev = 0 '
Do Until rst.EOF
qty_oh = rst!qty_oh
qty_r = rst!qty_r
qcqty_oh = rst!qcqty_oh
item = rst!item
If item_prev = item Then
If new_qoh > qty_r Then
new_qoh = new_qoh_prev - qty_r
End If
ElseIf item_prev = item Then
If new_qoh < qty_r Then
If qcqty_oh > qty_r Then
qcnew_qoh = (new_qoh_prev + qcqty_oh) - newqty_r
End If
Else: new_qoh = qty_oh - qty_r
End If
'MsgBox New_USOH
rst.Edit
rst!new_qoh = new_qoh
rst!qcnew_qoh = qcnew_qoh
rst.Update
item_prev = rst!item
new_qoh_prev = rst!new_qoh
qcnew_qoh_prev = rst!qcnew_qoh
rst.MoveNext
Loop
' OpenQuery (3)
End Function
tbl-order-age.xls
In the event that it runs negative, that is fine at the end, but it can only do that after it has reduced all good, then all inspection.
I have been trying to get some existing code that was in use here to perform this function, but I think I am stuck at this point. I keep getting a Loop without Do message and try as I might, I cannot figure out which of my changes is causing it.
Prior to the Loop without Do error, I was getting the inventory levels to reduce, but only on the Good Inventory portion, the QC/Inspection portion was remaining the same (though I think I was close to fixing that). Any help would be great, because I do not think that I am far off.
Here is the code below. I also attached an Excel file which is the basic idea of what the result would be. Green is the start of normal deductions, Yellow is out of QC, Red is the end of the line. Hopefully this is all clear enough. I will be back online around 9 am (need to finally go to sleep for a few hours).
Dim rst As DAO.Recordset
Dim SQLQuery As String
Dim qty_oh As Double 'asoh
Dim qty_r As Double 'total_qty
Dim new_qoh As Double 'new_usoh
Dim new_qoh_prev As Double 'new_usoh_prev
Dim item_prev As String 'Item_No_Prev
Dim item As String 'Item_No
Dim ord_no As String 'Ord_No
' Dim Ord_Type As String
Dim status As String
Dim start_date As Date
Dim qcqty_oh As Double
Dim qcnew_qoh As Double
Dim qcnew_qoh_prev As Double
Dim new_qtyr As Double
' OpenQuery (2)
Set db = CurrentDb
DBEngine.SetOption dbMaxLocksPerFile, 200000
SQLQuery = "SELECT tbl_order_age.ord_no, tbl_order_age.item, tbl_order_age.qty_oh, tbl_order_age.qty_r, tbl_order_age.new_qoh, tbl_order_age.status, tbl_order_age.ord_no, tbl_order_age.start_date, tbl_order_age.qcqty_oh, tbl_order_age.newqty_r, tbl_order_age.qcnew_qoh FROM tbl_order_age order by tbl_order_age.item, tbl_order_age.status, tbl_order_age.start_date,t
'MsgBox SQLQuery
Set rst = db.OpenRecordset(SQLQuery)
rst.MoveFirst
item_prev = ""
new_qoh_prev = 0
qcnew_qoh_prev = 0 '
Do Until rst.EOF
qty_oh = rst!qty_oh
qty_r = rst!qty_r
qcqty_oh = rst!qcqty_oh
item = rst!item
If item_prev = item Then
If new_qoh > qty_r Then
new_qoh = new_qoh_prev - qty_r
End If
ElseIf item_prev = item Then
If new_qoh < qty_r Then
If qcqty_oh > qty_r Then
qcnew_qoh = (new_qoh_prev + qcqty_oh) - newqty_r
End If
Else: new_qoh = qty_oh - qty_r
End If
'MsgBox New_USOH
rst.Edit
rst!new_qoh = new_qoh
rst!qcnew_qoh = qcnew_qoh
rst.Update
item_prev = rst!item
new_qoh_prev = rst!new_qoh
qcnew_qoh_prev = rst!qcnew_qoh
rst.MoveNext
Loop
' OpenQuery (3)
End Function
tbl-order-age.xls
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
Capricorn1, that worked and got me past the Loop without Do.
However, the QC part is getting set to 0 instantly, long before it should. Does the update portion at the end require some criteria to make it fire only when the criteria are met in the IF portion?
However, the QC part is getting set to 0 instantly, long before it should. Does the update portion at the end require some criteria to make it fire only when the criteria are met in the IF portion?
<the QC part is getting set to 0 instantly, long before it should.>
well, you have to rethink the process and logic you are executing using your codes
well, you have to rethink the process and logic you are executing using your codes
Without a sample of the data this would be hard to diagnose.
And WHAT exactly is getting set to 0? You say "the QC part", there are lots of variables and fields called qcSOMETHING
ASKER
The data was in the attached excel file. In any event, what I did was split the function into two, the first part to reduce the Good Inventory. Then once that was reduced, a second with some criteria to limit the results which accomplished what I wanted in the Inspection/QC qty.
Thank you for the advice and help. Getting the logic (Back to the drawing board) comment was a good idea.
Final code, in the event someone could use it. Runs about 10 seconds against 9000 records.
Option Explicit
Public Function CalcAGE1()
Dim rst As DAO.Recordset, db As DAO.Database
Dim SQLQuery As String
Dim qty_oh As Double 'asoh
Dim qty_r As Double 'total_qty
Dim new_qoh As Double 'new_usoh
Dim new_qoh_prev As Double 'new_usoh_prev
Dim item_prev As String 'Item_No_Prev
Dim item As String 'Item_No
Dim ord_no As String 'Ord_No
' Dim Ord_Type As String
Dim status As String
Dim start_date As Date
Dim qcqty_oh As Double
Dim qcnew_qoh As Double
Dim qcnew_qoh_prev As Double
Dim new_qtyr As Double
' OpenQuery (2)
Set db = CurrentDb
DBEngine.SetOption dbMaxLocksPerFile, 200000
SQLQuery = "SELECT tbl_order_age.ord_no, tbl_order_age.item, tbl_order_age.qty_oh, tbl_order_age.qty_r, tbl_order_age.new_qoh, tbl_order_age.status, tbl_order_age.ord_no, tbl_order_age.start_date FROM tbl_order_age order by tbl_order_age.item, tbl_order_age.status, tbl_order_age.start_date,t
'MsgBox SQLQuery
Set rst = db.OpenRecordset(SQLQuery)
rst.MoveFirst
item_prev = ""
new_qoh_prev = 0
Do Until rst.EOF
qty_oh = rst!qty_oh
qty_r = rst!qty_r
item = rst!item
If item_prev = item Then
new_qoh = new_qoh_prev - qty_r
Else
new_qoh = qty_oh - qty_r
End If
'MsgBox New_USOH
rst.Edit
rst!new_qoh = new_qoh
rst.Update
item_prev = rst!item
new_qoh_prev = rst!new_qoh
rst.MoveNext
Loop
' OpenQuery (3)
End Function
Public Function CalcAGE2()
Dim rst As DAO.Recordset, db As DAO.Database
Dim SQLQuery As String
Dim qty_oh As Double 'asoh
Dim qty_r As Double 'total_qty
Dim new_qoh As Double 'new_usoh
Dim new_qoh_prev As Double 'new_usoh_prev
Dim item_prev As String 'Item_No_Prev
Dim item As String 'Item_No
Dim ord_no As String 'Ord_No
' Dim Ord_Type As String
Dim status As String
Dim start_date As Date
Dim qcqty_oh As Double
Dim qcnew_qoh As Double
Dim qcnew_qoh_prev As Double
Dim newqty_r As Double
' OpenQuery (2)
Set db = CurrentDb
DBEngine.SetOption dbMaxLocksPerFile, 200000
SQLQuery = "SELECT tbl_order_age.ord_no, tbl_order_age.item, tbl_order_age.qty_oh, tbl_order_age.qty_r, tbl_order_age.new_qoh, tbl_order_age.status, tbl_order_age.ord_no, tbl_order_age.start_date, tbl_order_age.qcqty_oh, tbl_order_age.newqty_r, tbl_order_age.qcnew_qoh FROM tbl_order_age where tbl_order_age.new_qoh < tbl_order_age.qty_R and qcqty_oh > 0 order by tbl_order_age.item, tbl_order_age.status, tbl_order_age.start_date,t
'MsgBox SQLQuery
Set rst = db.OpenRecordset(SQLQuery)
rst.MoveFirst
item_prev = ""
qcnew_qoh_prev = 0
Do Until rst.EOF
qcqty_oh = rst!qcqty_oh
newqty_r = rst!newqty_r
item = rst!item
new_qoh = rst!new_qoh
If item_prev = item Then
qcnew_qoh = qcnew_qoh_prev - newqty_r
Else
qcnew_qoh = qcqty_oh + new_qoh - qty_r
End If
'MsgBox New_USOH
rst.Edit
rst!qcnew_qoh = qcnew_qoh
rst.Update
item_prev = rst!item
qcnew_qoh_prev = rst!qcnew_qoh
rst.MoveNext
Loop
' OpenQuery (3)
End Function
Thank you for the advice and help. Getting the logic (Back to the drawing board) comment was a good idea.
Final code, in the event someone could use it. Runs about 10 seconds against 9000 records.
Option Explicit
Public Function CalcAGE1()
Dim rst As DAO.Recordset, db As DAO.Database
Dim SQLQuery As String
Dim qty_oh As Double 'asoh
Dim qty_r As Double 'total_qty
Dim new_qoh As Double 'new_usoh
Dim new_qoh_prev As Double 'new_usoh_prev
Dim item_prev As String 'Item_No_Prev
Dim item As String 'Item_No
Dim ord_no As String 'Ord_No
' Dim Ord_Type As String
Dim status As String
Dim start_date As Date
Dim qcqty_oh As Double
Dim qcnew_qoh As Double
Dim qcnew_qoh_prev As Double
Dim new_qtyr As Double
' OpenQuery (2)
Set db = CurrentDb
DBEngine.SetOption dbMaxLocksPerFile, 200000
SQLQuery = "SELECT tbl_order_age.ord_no, tbl_order_age.item, tbl_order_age.qty_oh, tbl_order_age.qty_r, tbl_order_age.new_qoh, tbl_order_age.status, tbl_order_age.ord_no, tbl_order_age.start_date FROM tbl_order_age order by tbl_order_age.item, tbl_order_age.status, tbl_order_age.start_date,t
'MsgBox SQLQuery
Set rst = db.OpenRecordset(SQLQuery)
rst.MoveFirst
item_prev = ""
new_qoh_prev = 0
Do Until rst.EOF
qty_oh = rst!qty_oh
qty_r = rst!qty_r
item = rst!item
If item_prev = item Then
new_qoh = new_qoh_prev - qty_r
Else
new_qoh = qty_oh - qty_r
End If
'MsgBox New_USOH
rst.Edit
rst!new_qoh = new_qoh
rst.Update
item_prev = rst!item
new_qoh_prev = rst!new_qoh
rst.MoveNext
Loop
' OpenQuery (3)
End Function
Public Function CalcAGE2()
Dim rst As DAO.Recordset, db As DAO.Database
Dim SQLQuery As String
Dim qty_oh As Double 'asoh
Dim qty_r As Double 'total_qty
Dim new_qoh As Double 'new_usoh
Dim new_qoh_prev As Double 'new_usoh_prev
Dim item_prev As String 'Item_No_Prev
Dim item As String 'Item_No
Dim ord_no As String 'Ord_No
' Dim Ord_Type As String
Dim status As String
Dim start_date As Date
Dim qcqty_oh As Double
Dim qcnew_qoh As Double
Dim qcnew_qoh_prev As Double
Dim newqty_r As Double
' OpenQuery (2)
Set db = CurrentDb
DBEngine.SetOption dbMaxLocksPerFile, 200000
SQLQuery = "SELECT tbl_order_age.ord_no, tbl_order_age.item, tbl_order_age.qty_oh, tbl_order_age.qty_r, tbl_order_age.new_qoh, tbl_order_age.status, tbl_order_age.ord_no, tbl_order_age.start_date, tbl_order_age.qcqty_oh, tbl_order_age.newqty_r, tbl_order_age.qcnew_qoh FROM tbl_order_age where tbl_order_age.new_qoh < tbl_order_age.qty_R and qcqty_oh > 0 order by tbl_order_age.item, tbl_order_age.status, tbl_order_age.start_date,t
'MsgBox SQLQuery
Set rst = db.OpenRecordset(SQLQuery)
rst.MoveFirst
item_prev = ""
qcnew_qoh_prev = 0
Do Until rst.EOF
qcqty_oh = rst!qcqty_oh
newqty_r = rst!newqty_r
item = rst!item
new_qoh = rst!new_qoh
If item_prev = item Then
qcnew_qoh = qcnew_qoh_prev - newqty_r
Else
qcnew_qoh = qcqty_oh + new_qoh - qty_r
End If
'MsgBox New_USOH
rst.Edit
rst!qcnew_qoh = qcnew_qoh
rst.Update
item_prev = rst!item
qcnew_qoh_prev = rst!qcnew_qoh
rst.MoveNext
Loop
' OpenQuery (3)
End Function
ASKER
I noticed I was missing some undefined items, so I fixed that, and I was wondering if my IF statements were missing something, so I added another one to see if that worked, since there was possible results that were not setup in the IF statements as of last night.
The new updated code is below.
Open in new window
Public Function CalcAGE1()
Dim rst As DAO.Recordset
Dim SQLQuery As String
Dim qty_oh As Double 'asoh
Dim qty_r As Double 'total_qty
Dim new_qoh As Double 'new_usoh
Dim new_qoh_prev As Double 'new_usoh_prev
Dim item_prev As String 'Item_No_Prev
Dim item As String 'Item_No
Dim ord_no As String 'Ord_No
Dim status As String
Dim start_date As Date
Dim qcqty_oh As Double
Dim qcnew_qoh As Double
Dim qcnew_qoh_prev As Double
Dim newqty_r As Double
' OpenQuery (2)
Set db = CurrentDb
DBEngine.SetOption dbMaxLocksPerFile, 200000
SQLQuery = "SELECT tbl_order_age.ord_no, tbl_order_age.item, tbl_order_age.qty_oh, tbl_order_age.qty_r, tbl_order_age.new_qoh, tbl_order_age.status, tbl_order_age.ord_no, tbl_order_age.start_date, tbl_order_age.qcqty_oh, tbl_order_age.qcnew_qoh tbl_order_age.newqty_r FROM tbl_order_age order by tbl_order_age.item, tbl_order_age.status, tbl_order_age.start_date,t
'MsgBox SQLQuery
Set rst = db.OpenRecordset(SQLQuery)
rst.MoveFirst
item_prev = ""
new_qoh_prev = 0
qcnew_qoh_prev = 0
Do Until rst.EOF
qty_oh = rst!qty_oh
qty_r = rst!qty_r
qcqty_oh = rst!qcqty_oh
newqty_r = rst!newqty_r
item = rst!item
If item_prev = item Then
If new_qoh > qty_r Then
new_qoh = new_qoh_prev - qty_r
End If
ElseIf item_prev = item Then
If new_qoh < qty_r Then
If qcqty_oh > qty_r Then
qcnew_qoh = (new_qoh_prev + qcqty_oh) - newqty_r
End If
ElseIf item_prev = item Then
If new_qoh < qty_r Then
If qcqty_oh < qty_r Then
qcnew_qoh = qcnew_qoh_prev - newqty_r
End If
Else
new_qoh = qty_oh - qty_r
End If
'MsgBox New_USOH
rst.Edit
rst!new_qoh = new_qoh
rst!qcnew_qoh = qcnew_qoh
rst.Update
item_prev = rst!item
new_qoh_prev = rst!new_qoh
qcnew_qoh_prev = rst!qcnew_qoh
rst.MoveNext
Loop
' OpenQuery (3)
End Function