修復VB Excel宏，搜索和復制/粘貼循環，共2張

Question

我是新手編碼員。 我找到了一些示例和教程來將我的代碼放到原處，但是它返回一個

錯誤“ 400”

我發現這並不是那么容易診斷。 我的目標很簡單。 我有兩張工作簿。 工作表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

我是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來將新的未知項目添加到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