Copying rows between worksheets based on a value

Question

In Sheet 2 has a set of rules in Column A.

Example in Column A there are multiple codes in each row, Rows B to H have data based on that correspond to that code.

In Sheet 1, I want to be able to place one of the codes and have VBA transfer rows B:H from Sheet 2 if this code matches with one in Column A.

Here is the program I have so far, It transfers rows over, but not the right row.

    Dim i As Integer
    Dim x As Integer
    Dim row As Integer
    Dim oldRow As Integer
    Dim found As Boolean
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Set ws1 = Worksheets("Sheet1")
    Set ws2 = Worksheets("Sheet2")
    Dim rng As Range, cell As Range, rng2 As Range, cell2 As Range

Set rng2 = ws2.Range("A1:A212")
Set rng = ws1.Range("A1:A212")

row = 1
oldRow = 1


For Each cell In rng
    row = row + 1

    For Each cell2 In rng2
        oldRow = oldRow + 1

        If cell.Value = cell2.Value Then
        row = row - 1
            ws1.Cells(row, 2) = ws2.Cells(oldRow, 2)
            ws1.Cells(row, 3) = ws2.Cells(oldRow, 3)
            ws1.Cells(row, 4) = ws2.Cells(oldRow, 4)
            ws1.Cells(row, 5) = ws2.Cells(oldRow, 5)
            ws1.Cells(row, 6) = ws2.Cells(oldRow, 6)
            ws1.Cells(row, 7) = ws2.Cells(oldRow, 7)
            ws1.Cells(row, 8) = ws2.Cells(oldRow, 8)
            found = True
        End If



    Next
    found = False
    oldRow = 1

Next

End Sub

I appreciate the help, Thank you.

Answer 1

I would change the code like this:

Sub test()
    Dim i As Integer
    Dim n As Integer
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Set ws1 = Worksheets("Sheet1")
    Set ws2 = Worksheets("Sheet2")

    'Cycles through the codes in sheet 1
    For i = 2 To ws1.Cells(ws1.Rows.Count, 1).End(xlUp).row Step 1
        For n = 2 To ws2.Cells(ws2.Rows.Count, 1).End(xlUp).row Step 1
            If ws1.Cells(i, 1).Value = ws2.Cells(n, 1).Value Then
                ws1.Cells(i, 2).Value = ws2.Cells(n, 2).Value
                ws1.Cells(i, 3).Value = ws2.Cells(n, 3).Value
                ws1.Cells(i, 4).Value = ws2.Cells(n, 4).Value
                ws1.Cells(i, 5).Value = ws2.Cells(n, 5).Value
                ws1.Cells(i, 6).Value = ws2.Cells(n, 6).Value
                ws1.Cells(i, 7).Value = ws2.Cells(n, 7).Value
                ws1.Cells(i, 8).Value = ws2.Cells(n, 8).Value
            End If
        Next n
    Next i
End Sub

Answer 2

Untested:

Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim rng As Range, f As Range, rng2 As Range
Dim c as range, cell as Range


Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
Set rng = ws1.Range("A1:A212")
Set rng2 = ws2.Range("A1:A212")

row = 1
oldRow = 1


For Each cell In rng.Cells
    if len(cell.value)>0 Then
        Set f = rng2.Find(cell.Value, lookin:=xlvalues, lookat:=xlWhole)
        if not f is nothing then
            cell.offset(0,1).Resize(1,7).Value = _
               f.offset(0,1).resize(1,7).Value
        end if   
    end if   
Next cell

Answer 3

Does this need to be in VBA? or are you able to use a the VLOOKUP worksheet function? because that is effectively what you are trying to achieve from the sounds of things.

You can also use VLOOKUP in VBA by using Application.WorksheetFunction.VLookup

Your problem might be because you are incrementing row and oldRow at the start of the loop instead of at the end.. so the first time it runs their values will be 2 instead of 1. You also then probably don't need to be doing row = row - 1 because its confusing.

Answer 4

You could do this will formulas. On 'Sheet1' cell B1 and copied over and down:

=IF(COUNTIF(Sheet2!$A:$A,$A1)=0,"",VLOOKUP($A1,Sheet2!$A:$H,COLUMN(B1),0))

If it has to be a macro, something like this should work for you:

Sub tgr()

    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim rngFound As Range
    Dim arrCodes As Variant
    Dim arrResults As Variant
    Dim varCode As Variant
    Dim ResultIndex As Long
    Dim cIndex As Long

    Set ws1 = ActiveWorkbook.Sheets("Sheet1")
    Set ws2 = ActiveWorkbook.Sheets("Sheet2")

    arrCodes = ws1.Range("A1", ws1.Cells(Rows.Count, "A").End(xlUp)).Value
    If Not IsArray(arrCodes) Then Exit Sub  'No data
    ReDim arrResults(1 To UBound(arrCodes, 1), 1 To 7)

    For Each varCode In arrCodes
        ResultIndex = ResultIndex + 1
        Set rngFound = ws2.Columns("A").Find(varCode, , xlValues, xlWhole)
        If Not rngFound Is Nothing Then
            For cIndex = 1 To UBound(arrResults, 2)
                arrResults(ResultIndex, cIndex) = WorksheetFunction.VLookup(varCode, ws2.Range("A:H"), cIndex + 1, False)
            Next cIndex
        End If
    Next varCode

    ws1.Range("B1").Resize(UBound(arrResults, 1), UBound(arrResults, 2)).Value = arrResults

End Sub