Visual Basic for Excel program to update the # of units on a particular purchase order that was downloaded into Excel
Christopher Clayton
06/01/2015
In this macro to update an imported purchase order for number of units across all lines, followed by an appropriate function call to re-export the data to an Enterprise Resource Planning database, whenever a matching item code with positive numbers of units is found on the external workbook column (the status report), that item code is added to the downloaded Excel copy.
The limitation is that if one line item on a purchase order has multiple delivery dates, that PO line is skipped.
WORKBOOK SHEET 1
This is the Excel file import display, for an order number exported from an enterprise resource planning system. The program involves column indices used for the ERP system paired with this instance of the program, such as the item code, description, and exit-factory date column indices.
WORKBOOK SHEET 2
This contains all user-defined parameters such as which file-name (must be open in the same instance of Excel) to check for # of units updates, and the column index for # of units in a particular row in that workbook.
# OF UNITS UPDATE ALGORITHM SAMPLE
Sub updateNumberUnits()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim fileNameMatch As String
Dim unitMatchColumn As Integer
'Dim POMatchColumn As Integer
Dim itemMatchColumn As Integer
Dim matchSheetIndex As Integer
Dim foundMatch As Boolean
Dim finalItemCode As Integer
Dim itemDescColumn As Integer
Dim workbookMatchRow As Integer
Dim currPORow As Integer
Dim currItemCodeSum As Integer
Dim currChangeCheckRow As Integer
Dim currLogRow As Integer
Dim errorLogFile As String
fileNameMatch = ThisWorkbook.Sheets(2).Cells(2, 1)
'POMatchColumn = ThisWorkbook.Sheets(2).Cells(2, 2)
itemMatchColumn = ThisWorkbook.Sheets(2).Cells(2, 3)
unitMatchColumn = ThisWorkbook.Sheets(2).Cells(2, 4)
workbookMatchRow = ThisWorkbook.Sheets(2).Cells(2, 5)
matchSheetIndex = ThisWorkbook.Sheets(2).Cells(2, 6)
itemDescColumn = ThisWorkbook.Sheets(2).Cells(2, 7)
'Update existing codes
currPORow = 4
foundMatch = False
currItemCodeSum = 0
foundMatch = False
errorLogFile = ThisWorkbook.Sheets(2).Cells(2, 8)
currChangeCheckRow = 4
currLogRow = 2
Do Until Workbooks(errorLogFile).Sheets(2).Cells(currLogRow, 1) = 0
currLogRow = currLogRow + 1
Loop
Do While ThisWorkbook.Sheets(1).Cells(currPORow, 1) <> 0
Do While Workbooks(fileNameMatch).Sheets(matchSheetIndex).Cells(workbookMatchRow, itemMatchColumn) <> 0
If ThisWorkbook.Sheets(1).Cells(currPORow, 2) = Workbooks(fileNameMatch).Sheets(matchSheetIndex).Cells(workbookMatchRow, itemMatchColumn) Then
currItemCodeSum = currItemCodeSum + Workbooks(fileNameMatch).Sheets(matchSheetIndex).Cells(workbookMatchRow, unitMatchColumn)
foundMatch = True
End If
workbookMatchRow = workbookMatchRow + 1
Loop
If foundMatch = True And ThisWorkbook.Sheets(1).Cells(currPORow, 11) <> currItemCodeSum And (currItemCodeSum - ThisWorkbook.Sheets(1).Cells(currPORow, 12) >= 0 Or ThisWorkbook.Sheets(1).Cells(currPORow, 11) - ThisWorkbook.Sheets(1).Cells(currPORow, 12) >= 0) Then 'There could be item code duplicates in the source. This is why whenever a match occurs in the previous code, we keep summing up a variable and only assign our order # the total sum, so we only have the totals of unique codes in the order. The changed # units must be greater than or equal to the balance already received, because one can't subtract from units already received.
ThisWorkbook.Sheets(1).Cells(currPORow, 11) = currItemCodeSum
ThisWorkbook.Sheets(1).Cells(currPORow, 11).Interior.Color = RGB(255, 0, 0)
'ThisWorkbook.Sheets(1).Cells(currPORow, 12).ClearContents
ElseIf foundMatch = True And currItemCodeSum < ThisWorkbook.Sheets(1).Cells(currPORow, 11) - ThisWorkbook.Sheets(1).Cells(currPORow, 12) Then 'If too many units are being reduced such that the balance already received is greater than the change, then the change cannot be done. Highlight the balance in red, that's the maximal amount that can be subtracted. Do this manually since the change may need to be reviewed by the factory and the customer.
ThisWorkbook.Sheets(1).Cells(currPORow, 12).Interior.Color = RGB(255, 0, 0)
ElseIf foundMatch = False And ThisWorkbook.Sheets(1).Cells(currPORow, 11) <> 0 And ThisWorkbook.Sheets(1).Cells(currPORow, 12) <> 0 Then 'Update non-matches to 0, assuming they are not already 0 (still open) (second test is whether they are open, i.e. that there are still receivables. This is so that items intentionally left off of some report due to being closed are not counted as a change
ThisWorkbook.Sheets(1).Cells(currPORow, 11) = 0
ThisWorkbook.Sheets(1).Cells(currPORow, 11).Interior.Color = RGB(255, 0, 0)
ElseIf foundMatch = False And ThisWorkbook.Sheets(1).Cells(currPORow, 12) = 0 Then 'These lines can be deleted to discount them from data import, because the receivables are 0 and thus they have been discounted from the report being drawn from
ThisWorkbook.Sheets(1).Cells(currPORow, 12).Interior.Color = RGB(255, 255, 0)
End If
currPORow = currPORow + 1
workbookMatchRow = ThisWorkbook.Sheets(2).Cells(2, 5)
foundMatch = False
currItemCodeSum = 0
Loop
'Add new item codes
currPORow = 4
finalItemCode = 4
foundMatch = False
workbookMatchRow = ThisWorkbook.Sheets(2).Cells(2, 5)
Do While Workbooks(fileNameMatch).Sheets(matchSheetIndex).Cells(workbookMatchRow, 1) <> 0
Do While ThisWorkbook.Sheets(1).Cells(currPORow, 1) <> 0
If ThisWorkbook.Sheets(1).Cells(currPORow, 2) = Workbooks(fileNameMatch).Sheets(matchSheetIndex).Cells(workbookMatchRow, itemMatchColumn) Then
foundMatch = True
End If
currPORow = currPORow + 1
Loop
If foundMatch = False And (Workbooks(fileNameMatch).Sheets(matchSheetIndex).Cells(workbookMatchRow, unitMatchColumn) <> 0 Or Workbooks(fileNameMatch).Sheets(matchSheetIndex).Cells(workbookMatchRow, unitMatchColumn) <> Null) Then
Do Until ThisWorkbook.Sheets(1).Cells(finalItemCode, 2) = 0
finalItemCode = finalItemCode + 1 'Get to the immediate blank row
Loop
ThisWorkbook.Sheets(1).Cells(finalItemCode, 2) = Workbooks(fileNameMatch).Sheets(matchSheetIndex).Cells(workbookMatchRow, itemMatchColumn) 'Add new item code
ThisWorkbook.Sheets(1).Cells(finalItemCode, 4) = Workbooks(fileNameMatch).Sheets(matchSheetIndex).Cells(workbookMatchRow, itemDescColumn)
ThisWorkbook.Sheets(1).Cells(finalItemCode, 11) = Workbooks(fileNameMatch).Sheets(matchSheetIndex).Cells(workbookMatchRow, unitMatchColumn) 'Add its # of units. If multiples of the same item code are added, one must consolidate duplicates though
ThisWorkbook.Sheets(1).Cells(currPORow, 11).Interior.Color = RGB(255, 0, 0)
ThisWorkbook.Sheets(1).Cells(finalItemCode, 8) = ThisWorkbook.Sheets(1).Cells(finalItemCode - 1, 8) 'Copy exit-factory date down to new item
'ThisWorkbook.Sheets(1).Cells(finalItemCode, 1) = ThisWorkbook.Sheets(1).Cells(finalItemCode - 1, 1) 'Add next line number in sequence from the last one
End If
foundMatch = False
workbookMatchRow = workbookMatchRow + 1
currPORow = 4
Loop
Do Until ThisWorkbook.Sheets(1).Cells(currChangeCheckRow, 2) = 0
If ThisWorkbook.Sheets(1).Cells(currChangeCheckRow, 11).Interior.Color = RGB(255, 0, 0) Then
Workbooks(errorLogFile).Sheets(2).Cells(currLogRow, 1) = ThisWorkbook.Sheets(1).Cells(currChangeCheckRow, 2)
Workbooks(errorLogFile).Sheets(2).Cells(currLogRow, 2) = ThisWorkbook.Sheets(1).Cells(currChangeCheckRow, 4)
Workbooks(errorLogFile).Sheets(2).Cells(currLogRow, 3) = ThisWorkbook.Sheets(1).Cells(2, 1)
Workbooks(errorLogFile).Sheets(2).Cells(currLogRow, 4) = ThisWorkbook.Sheets(1).Cells(2, 13)
Workbooks(errorLogFile).Sheets(2).Cells(currLogRow, 5) = ThisWorkbook.Sheets(1).Cells(currChangeCheckRow, 11)
Workbooks(errorLogFile).Sheets(2).Cells(currLogRow, 6) = ThisWorkbook.Sheets(1).Cells(currChangeCheckRow, 1)
currChangeCheckRow = currChangeCheckRow + 1
currLogRow = currLogRow + 1
Else
currChangeCheckRow = currChangeCheckRow + 1
End If
Loop
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub