I am very new to VBA and need it to perform a series of things in excel.

I have a spreadsheet with over 10000 rows and need to search it using InputBox (UPC field, input is from a barcode scanner)

Once it's found, I need it to select the row of the found cell, copy it, and paste it to another sheet.

This process should loop until the user cancels the InputBox

I have successfully done this, but it seems very inconsistent; it routinely gives me an error on the SelectCells.Select line, but not every time.

Any help would be greatly GREATLY appreciated.

This is what I have so far:

Sub Scan()

Do Until IsEmpty(ActiveCell)
    Dim Barcode As Double
    Barcode = InputBox("Scan Barcode")
    Dim ws As Worksheet
    Dim SelectCells As Range
    Dim xcell As Object
    
    Set ws = Worksheets("Sheet1")

For Each xcell In ws.UsedRange.Cells
    If xcell.Value = Barcode Then
        If SelectCells Is Nothing Then
        Set SelectCells = Range(xcell.Address)
        Else
        Set SelectCells = Union(SelectCells, Range(xcell.Address))
        End If
    End If
Next

SelectCells.Select
Set SelectCells = Nothing
 ActiveCell.Rows("1:1").EntireRow.Select
    Selection.Copy
    Sheets("Sheet2").Select
    ActiveSheet.Paste
    Sheets("Sheet1").Select
    
    
Loop

End Sub

CodePudding user response：

You can try something like this:

Sub Scan()
    
    Dim Barcode As String, rngData As Range, m, rngDest As Range
    
   'Column with barcodes
    With Worksheets("Sheet1")
        Set rngData = .Range("A1", .Cells(Rows.Count, "A").End(xlUp))
    End With
    'First paste postion
    Set rngDest = Worksheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Offset(1)
    
    Do
        Barcode = InputBox("Scan Barcode")
        If Len(Barcode) = 0 Then Exit Do
        
        m = Application.Match(Barcode, rngData, 0)
        If Not IsError(m) Then
            rngData.Rows(m).Resize(1, 10).Copy rngDest 'copy 10 columns to Sheet2
            Set rngDest = rngDest.Offset(1)
        Else
            'if no match then what?
        End If
    Loop

End Sub

Depending on how your barcodes are stored (as text, or a numeric values) you may need to use CDbl(Barcode) inside the call to Match()

CodePudding user response：

Copy Rows

Option Explicit

Sub Scan()
    
    Const sName As String = "Sheet1"
    Const Header As String = "Barcode"
    
    Const dName As String = "Sheet2"
    Const dFirstCellAddress As String = "A2"
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim surg As Range: Set surg = sws.UsedRange
    Dim slCell As Range
    Set slCell = surg.Cells(surg.Rows.Count, surg.Columns.Count)
    Dim shCell As Range
    Set shCell = surg.Find(Header, slCell, xlFormulas, xlWhole, xlByRows)
    
    If shCell Is Nothing Then
        MsgBox "The cell containing the header '" & Header _
            & "' was not found.", vbCritical
        Exit Sub
    End If
    
    Dim sfCol As Long: sfCol = surg.Column
    Dim srg As Range
    Set srg = sws.Range(sws.Cells(shCell.Row   1, sfCol), slCell)
    
    Dim scColIndex As Long: scColIndex = shCell.Column - sfCol   1
    Dim scrg As Range: Set scrg = srg.Columns(scColIndex)
    
    Dim SelectedRows As Range
    Dim Barcode As Variant
    Dim srIndex As Variant
    
    Do
        
        Barcode = InputBox("Scan Barcode")
        If Len(CStr(Barcode)) = 0 Then Exit Do
        
        If IsNumeric(Barcode) Then
            srIndex = Application.Match(CDbl(Barcode), scrg, 0)
            If IsNumeric(srIndex) Then
                If SelectedRows Is Nothing Then
                    Set SelectedRows = srg.Rows(srIndex)
                Else
                    Set SelectedRows = Union(SelectedRows, srg.Rows(srIndex))
                End If
            End If
        End If
        
    Loop
    
    If SelectedRows Is Nothing Then
        MsgBox "No scan results.", vbExclamation
        Exit Sub
    End If
    
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    Dim dfCell As Range: Set dfCell = dws.Range(dFirstCellAddress)
    Dim durg As Range: Set durg = dws.UsedRange
    Dim dlRow As Long: dlRow = durg.Row   durg.Rows.Count - 1
    
    Dim dlCell As Range
    
    If dlRow < dfCell.Row Then
        Set dlCell = dfCell
    Else
        Set dlCell = dws.Cells(dlRow   1, dfCell.Column)
    End If
    
    SelectedRows.Copy dlCell
    
    MsgBox "Rows copied.", vbInformation
    
End Sub