VBA代码循环遍历一列数字，搜索每个数字并将整行复制到工作表

Question

我正在寻找 Excel 的 VBA 代码，它将遍历一个工作表中的单列数字（条形码），在另一个工作表（同一工作簿）上查找每个数字（条形码）的完全匹配，然后复制输入搜索词编号（条形码）旁边的列中原始工作表的整行。

我找到了此代码，但它没有遍历工作表（搜索词）中的数字（条形码）列。搜索范围应该是包含所有数据的整个工作表。

Sub Copy()

Dim objWorksheet As Worksheet
Dim rngBurnDown As Range
Dim rngCell As Range
Dim strPasteToSheet As String

'Used for the new worksheet we are pasting into
Dim objNewSheet As Worksheet
Dim rngNextAvailbleRow As Range

'Define the worksheet with our data
Set objWorksheet = ActiveWorkbook.Sheets("Burn Down")

'Dynamically define the range to the last cell.
'This doesn't include and error handling e.g. null cells
'If we are not starting in A1, then change as appropriate
Set rngBurnDown = objWorksheet.Range("A3:A" & objWorksheet.Cells(Rows.Count, "A").End(xlUp).Row)

'Now loop through all the cells in the range
For Each rngCell In rngBurnDown.Cells

objWorksheet.Select

If rngCell.Value <> "" Then
    'select the entire row
    rngCell.EntireRow.Select

    'copy the selection
    Selection.Copy

    'Now identify and select the new sheet to paste into
    Set objNewSheet = ActiveWorkbook.Sheets("Burn Down " & rngCell.Value)
    objNewSheet.Select

    'Looking at your initial question, I believe you are trying to find the next     available row
    Set rngNextAvailbleRow = objNewSheet.Range("A1:A" & objNewSheet.Cells(Rows.Count, "A").End(xlUp).Row)
'MsgBox "Success"
    objNewSheet.Range("A" & rngNextAvailbleRow.Rows.Count + 1).Select

    ActiveSheet.Paste

End If

Next rngCell

objWorksheet.Select
objWorksheet.Cells(1, 1).Select

End Sub 

Answer 1

Sub MyCopy(ByRef wsFrom As Worksheet)
  'wsFrom       = is where all the barcodes are kept.
  'wsTo         = is where we should paste the entirerow.

Dim rngBurnDown As Range, rngCell As Range, rngReceiver As Range
Dim wsTo As Worksheet
Dim FailedBarcode As Collection

Set FailedBarcode = New Collection '<~  will record failed barcode later
Set rngBurnDown = wsFrom.Range("A3:A" & wsFrom.Cells(Rows.Count, "A").End(xlUp).Row) '<~ get the range of barcode

For Each rngCell In rngBurnDown.Cells '<~ Loops through the available barcode
  On Error GoTo WorkBookNotPresent '<~ on error go to error handler /!\
  Set wsTo = ThisWorkbook.Sheets("Burn Down" & rngCell.Value) '<!~ set the reciver worksheet
  Set rngReceiver = wsTo.Range("A1048576").End(xlUp).Offset(1, 0).Row '<~ set the lastrow
  rngCell.EntireRow.Copy Destination:=rngReceiver '<~ actual copying and pasting
NextItem: '<~ /?\ resume here after the error
Next

MsgBox "task complete"

'just to show if there are failed barcodes
Dim i As Integer
Dim aHolder() As Variant
With FailedBarcode
  If .Count > 0 Then
    ReDim aHolder(1 To .Count + 1)
    For i = 1 To .Count
      aHolder(i) = .Item(i)
    Next
    MsgBox "and with failed barcode:" & Join(aHolder, ", ")
  End If
End With

Exit Sub
WorkBookNotPresent: '<~ /!\ if error encountered go here
  FailedBarcode.Add rngCell.Value, rngCell.Address(0, 0) '<~ add the barcode to the collection
  Resume NextItem '<~ resume to next item /?\

End Sub

应该这样称呼

mycopy [name of worksheet]

发布此答案而不进行测试。