With loop For Each trying to copy rows in to another sheet, but having problems with updating the La-CodePudding

So I have 6 Rows that I want to copy in to another sheet.
My problem is that the first row from sheet "data" copies and pastes correctly on sheet "blue" row 2.
But on the second loop, row two from sheet "data" copies and pastes on sheet "blue" also on row 2.
Then on the third loop, same thing happens.
Finaly when the loop finishes I only have the last row from sheet "data" pasted on sheet "blue" on row 2.
I guess the problem is, my line of code LastRowBlue isint updating loop by loop.

I know I can copy the whole thing with out loop, but this is an example for a bigger exercise.

¿Any Ideas? I almost got it!

Sub CopyPasteInOtherSheetWithLoop()
Dim BallsColorList As Range
Dim LastRowBallsColorList As Integer
Dim LastRowBlue As Integer

LastRowBallsColorList = Cells(Rows.Count, "B").End(xlUp).Row
Set BallsColorList = Range(Cells(2, "B"), Cells(LastRowBallsColorList, "B"))


For Each Ball In BallsColorList
    LastRowBlue = Sheets("blue").Cells(Rows.Count).End(xlUp).Row   1
    Range(Ball.Offset(0, -1), Ball.Offset(0, 2)).Copy Sheets("blue").Cells(LastRowBlue, "A")
Next
End Sub

enter image description here enter image description here

CodePudding user response：

Copy Using a Loop

Here is one of the countless ways you could do it.
By introducing more object variables (workbook-worksheet-range), it clearly shows what is what and more importantly, where it is located.
Rename the variables if you feel they're too generic.

Sub CopyUsingLoop()

    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code

    ' Source
    Dim sws As Worksheet: Set sws = wb.Worksheets("Data")
    Dim scrg As Range
    Set scrg = sws.Range("B2", sws.Cells(sws.Rows.Count, "B").End(xlUp))
    Dim srg As Range: Set srg = scrg.EntireRow.Columns("A:D")

    ' Destination
    Dim dws As Worksheet: Set dws = wb.Worksheets("Blue")
    Dim dCell As Range
    Set dCell = dws.Cells(dws.Rows.Count, "A").End(xlUp)

    ' Loop.
    
    Dim sCell As Range
    Dim sr As Long
    Dim dr As Long
    
    For Each sCell In scrg.Cells
        sr = sr   1
        If StrComp(CStr(sCell.Value), "Blue", vbTextCompare) = 0 Then
            dr = dr   1
            srg.Rows(sr).Copy dCell.Offset(dr)
        End If
    Next sCell
    
End Sub