修复VBA Excel宏，搜索和复制/粘贴循环，2张

Question

我是新手编码员。我找到了一些示例和教程来将我的代码放到原来的位置，但它会返回一个

错误“400”

我发现它并不容易诊断。我的目标很简单。我有一个2张工作簿。表1是订单表（“PO”），表2是数据库（“DataBase”）。我在工作簿中有这个子例程（不是其中一个表）。它提示用户扫描条形码，然后在工作表“DataBase”中搜索该部件号，然后将接下来的3个单元格向右复制/粘贴回原始工作表“PO”。

还有一些内置功能，例如在扫描特定条形码时终止循环的能力（xxxDONExxxx）。我也试图找到一种方法来返回错误消息（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

表1 - “PO”

表2 - “数据库”

Answer 1

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

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

我是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 3

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

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