数値の列をループして各数値を検索し、行全体をワークシートにコピーする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] 

のように呼び出されなければなりません。