CODEWITHSUNDEEP
excelvba
Kevin McDermott
Kevin McDermott

Reputation: 1

VBA code to loop through a column of numbers, search for each number & copy the entire row to a worksheet

I'm looking for VBA code for Excel that will loop through a single column of numbers (barcodes) in one worksheet, look for an exact match for each number (barcode) on another worksheet (same workbook), and then copy the entire row to the original worksheet in the column next to the input search term number (barcode).

I found this code but it doesn't loop through the column of numbers (barcodes) in worksheet (search terms). The search range should be the entire worksheet with all the data. 

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

Upvotes: 0

Views: 385

Answers (1)

Romcel Geluz
Romcel Geluz

Reputation: 603

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

and should be called like

mycopy [name of worksheet]

Posting this answer without testing it.

Upvotes: 1

Related Questions