Find from InputBox, copy row of found cell without using .Select - excel

Question

I have a spreadsheet with over 10000 rows. I need to search it using InputBox (UPC field, input is from a barcode scanner).
I need to copy the row of the found cell, and paste it to another sheet.
This process should loop until the user cancels the InputBox.
I have done this, but it gives me an error on the SelectCells.Select line, but not every time.
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

Answer 1

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

Answer 2

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("D1", .Cells(Rows.Count, "D").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) 'Barcodes formatted as text
m = Application.Match(CDbl(Barcode), rngData, 0) 'Barcodes formatted as numbers
If Not IsError(m) Then
rngData.Rows(m).EntireRow.Copy rngDest 'copy to Sheet2
Set rngDest = rngDest.Offset(1)
Else
'if no match then what?
Debug.Print "no match"
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()