Fix VB Excel Macro, search and copy/paste loop, 2 sheets - vba

Question

I am a novice coder. I have found a few examples and tutorials to get my code to where it is, but it returns an
error "400"
which I have found to not be all that easy to diagnose. My goal is simple. I have a 2 sheet workbook. Sheet 1 is an order form ("PO"), and sheet 2 is a database ("DataBase"). I have this subroutine in the workbook (not one of the sheets). It prompts the user to scan a barcode, and then searches sheet "DataBase" for that part number, and then copy/pastes the next 3 cells to the right back into the original sheet "PO".
There is a little more built in, like the ability to terminate the loop if a specific barcode is scanned (xxxDONExxxx). I also am trying to find a way to to return an error message (ErrMsg2) if no match is found.
If I step through the subroutine using F8, it gets past the scanner input, and then fails the line with the note ('FAIL'). I would appreciate some help to get this working.
Option Explicit
Sub inventory()
'**** Define variables ****'
Dim partnumber As String
Dim lastrow As Integer
Dim i As Integer
Dim x As Integer
'Dim xxxDONExxxx As String
'**** Clear paste area in sheet "PO" ****'
Sheets("PO").Range("A17:F31").ClearContents
'**** Set row count ****'
lastrow = 100 'Sheets("DataBase").Range("B500").End(x1Up).Row
'**** select first cell to paste in****'
Range("A17").Select
'**** loop for scanning up to 30 lines ****'
For i = 1 To 30
'**** Prompt for input ****'
partnumber = InputBox("SCAN PART NUMBER")
'**** Abort if DONE code is scanned ****'
If ("partnumber") = ("xxxDONExxxx") Then GoTo ErrMsg1
'**** search DataBase for match in B, copy CDE /paste in PO BDE****'
For x = 2 To lastrow
If ("partnumber") = Sheets("DataBase").Range("x, 2") Then '*FAIL*'
ActiveCell.Offset(0, 1) = Sheets("DataBase").Cells(x, 1)
ActiveCell.Offset(0, 2) = Sheets("DataBase").Cells(x, 2)
ActiveCell.Offset(0, 3) = Sheets("DataBase").Cells(x, 3)
End If
Next x
Next i
ErrMsg1:
MsgBox ("Operation Done - user input")
ErrMsg2:
MsgBox ("Part Number does not Exist, add to DataBase!")
End Sub
Sheet 1 - "PO"
Sheet 2 - "Database"

Answer 1

I know there are more efficient ways to do this, but this will do what you expect:
Option Explicit
Sub inventory()
'**** Define variables ****'
Dim wsData As Worksheet: Set wsData = Sheets("DataBase")
Dim wsPO As Worksheet: Set wsPO = Sheets("PO")
Dim partnumber As String
Dim lastrow As Long
Dim i As Long
Dim x As Long
Dim Found As String
Found = False
'**** Clear paste area in sheet "PO" ****'
wsPO.Range("A17:F31").ClearContents
'**** Set row count on Database Sheet ****'
lastrow = wsData.Cells(wsData.Rows.Count, "B").End(xlUp).Row
'select the last row with data in the given range
wsPO.Range("A17").Select
ScanNext:
'**** Prompt for input ****'
partnumber = InputBox("SCAN PART NUMBER")
'**** Abort if DONE code is scanned ****'
If partnumber = "xxxDONExxxx" Then
MsgBox ("Operation Done - user input")
Exit Sub
Else
Selection.Value = partnumber
End If
'**** search DataBase for match in B, copy CDE /paste in PO BDE****'
For x = 2 To lastrow
If wsPO.Cells(Selection.Row, 1) = wsData.Cells(x, 2) Then
wsPO.Cells(Selection.Row, 2) = wsData.Cells(x, 3)
wsPO.Cells(Selection.Row, 5) = wsData.Cells(x, 4)
wsPO.Cells(Selection.Row, 6) = wsData.Cells(x, 5)
Found = "True"
End If
Next x
If Found = "False" Then
MsgBox "Product Not Found in Database!", vbInformation
Selection.Offset(-1, 0).Select
Else
Found = "False"
End If
If Selection.Row < 31 Then
Selection.Offset(1, 0).Select
GoTo ScanNext
Else
MsgBox "This inventory page is now full!", vbInformation
End If
End Sub

Answer 2

I'm a big fan of application.match. For example:
If IsNumeric(Application.Match(LookUpValue, LookUpRange, 0)) Then
startCol = Application.Match(LookUpValue, LookUpRange, 0)
Else
MsgBox "Unable to find " & LookUpValue & " within " & LookUpRange & ". Please check the data and try again. The macro will now exit"
End
End If
This tests if the item exists in the dataset, then does something with it if it exists. If it doesn't exist, you can throw an error message. Massaging it slightly for your needs:
If IsNumeric(Application.Match(PartNumber, DataBaseRange, 0)) Then
'Do things with matching
Else
'Do things when you don't have a match
End
End If

Answer 3

Try this rethink version. You should create a Sub to add new unknown items into the Database range, otherwise you need to quit current process, add new item into Database, then rescan all items from beginning!
Option Explicit
Sub inventory()
'**** Define variables ****'
Const STOP_ID As String = "xxxDONExxxx"
Const START_ROW As Long = 17 ' based on "A17:F31"
Const LAST_ROW As Long = 31 ' based on "A17:F31"
Dim partnumber As String, sDescription As String, i As Long
Dim oRngDataBase As Range
'**** Clear paste area in sheet "PO" ****'
Worksheets("PO").Range("A17:F31").ClearContents
' Determine the actual database range
Set oRngDataBase = Intersect(Worksheets("DataBase").UsedRange, Worksheets("DataBase").Columns("B:E"))
i = START_ROW
On Error Resume Next
Do
partnumber = InputBox("SCAN PART NUMBER")
If Len(partnumber) = 0 Then
If partnumber = STOP_ID Then
MsgBox "Operation Done - user input", vbInformation + vbOKOnly
Exit Do
End If
sDescription = WorksheetFunction.VLookup(partnumber, oRngDataBase, 2, False) ' Description
If Len(sDescription) = 0 Then
If vbYes = MsgBox("Part Number (" & partnumber & ") does not Exist, add to DataBase Now?", vbExclamation + vbYesNo) Then
' Suggest you to create a new Sub to insert data and call it here
' Update the Database Range once added new item
Set oRngDataBase = Intersect(Worksheets("DataBase").UsedRange, Worksheets("DataBase").Columns("B:E"))
End If
'NOTE: Answer No will skip this scanned unknown partnumber
Else
Worksheets("PO").Cells(i, "A").Value = partnumber
Worksheets("PO").Cells(i, "B").Value = sDescription
Worksheets("PO").Cells(i, "C").Value = WorksheetFunction.VLookup(partnumber, oRngDataBase, 3, False) ' QTY
Worksheets("PO").Cells(i, "D").Value = WorksheetFunction.VLookup(partnumber, oRngDataBase, 4, False) ' PRICE
i = i + 1
End If
End If
Loop Until i > LAST_ROW
On Error GoTo 0
Set oRngDataBase = Nothing
End Sub