修复 VB Excel 宏、搜索和 copy/paste 循环，2 张

Question

我是一名编码新手。我找到了一些示例和教程来将我的代码放到它所在的位置，但它 return 是

error "400"

我发现诊断起来并不那么容易。我的目标很简单。我有一个 2 sheet 工作簿。 Sheet1是订单（"PO"），sheet2是数据库（"DataBase"）。我在工作簿中有这个子例程（不是 sheet 之一）。它提示用户扫描条形码，然后搜索 sheet "DataBase" 该部件号，然后 copy/pastes 右边的下 3 个单元格返回原始 sheet "PO"。

还有一些内置功能，例如扫描特定条形码时终止循环的功能 (xxxDONExxxx)。如果找不到匹配项，我也在尝试找到一种方法 return 一条错误消息 (ErrMsg2)。

如果我使用 F8 单步执行子例程，它会通过扫描仪输入，然后失败并显示注释 ('FAIL')。我将不胜感激，希望能帮助我完成这项工作。

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

我是 application.match 的超级粉丝。例如：

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

这会测试该项目是否存在于数据集中，如果存在则对其进行处理。如果不存在，您可以抛出一条错误消息。根据您的需要稍微按摩一下：

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 2

我知道有更有效的方法可以做到这一点，但这会达到您的预期：

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 3

试试这个重新思考的版本。您应该创建一个 Sub 以将新的未知项目添加到数据库范围内，否则您需要退出当前进程，将新项目添加到数据库中，然后重新扫描所有项目从头开始！

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

修复 VB Excel 宏、搜索和 copy/paste 循环，2 张

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

excel

vba

barcode-scanner