Copy specific Rows from one workbook to another - vba

Question

I'm having trouble copying specific Rows with vba.
Here my Code:
Dim color1 As Integer
Dim color2 As Integer
Dim lines As Integer
Workbooks.Open Filename:="D:\01 January.xlsm", _
UpdateLinks:=0
lines = WorksheetFunction.CountA(Range("U:U")) - 1
Dim i As Integer
For i = 6 To lines + 6
color1 = Cells(i, 21).Value
color2 = Cells(i, 22).Value
If IsNumeric(Cells(i, 21)) Then
Select Case color1 & color2
Case Evaluate("=White") & Evaluate("=Blue")
Rows(i & ":" & i).Select
Case Evaluate("=Yellow") & Evaluate("=Yellow")
Rows(i & ":" & i).Select
Case Evaluate("=Yellow") & Evaluate("=Green")
Rows(i & ":" & i).Select
End Select
End If
Next i
Selection.Copy
Windows("Test.xlsm").Activate
Rows("11:11").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End Sub
So as you might see, I am trying to select Rows, that meet the criteria in the January.xlsm and paste them afterwards into the test.xlsm
At the moment it only pastes the last selected row and not all of them.
I'm pretty new to vba, so I would really need your help here. What I got in my mind, is to put all the needed rows into an array and then copy it into the other workbook. But no idea if thats good or just rubish and if that would work, I can't find a solution...
Thanks for all your help!

Answer 1

The reason it only pastes the last row is because you're looping through selecting the individual rows but not doing anything with them. See amended code.
I've removed the redundant selections in the case statement and provided a range/union combo to create your custom range to ensure you're only pasting to the worksheet once.
Dim color1 As Integer
Dim color2 As Integer
Dim lines As Integer
Workbooks.Open Filename:="D:\01 January.xlsm", _
UpdateLinks:=0
lines = WorksheetFunction.CountA(Range("U:U")) - 1
Dim i As Integer
Dim rngUnion As Range
Dim booCopy As Boolean
For i = 6 To lines + 6
booCopy = True
color1 = Cells(i, 21).Value
color2 = Cells(i, 22).Value
If IsNumeric(Cells(i, 21)) Then
Select Case color1 & color2
Case Evaluate("=White") & Evaluate("=Blue")
Case Evaluate("=Yellow") & Evaluate("=Yellow")
Case Evaluate("=Yellow") & Evaluate("=Green")
Case Else
booCopy = False
End Select
End If
If booCopy = True Then
If rngUnion Is Nothing Then
Set rngUnion = Rows(i & ":" & i)
Else
Set rngUnion = Union(rngUnion, Rows(i & ":" & i))
End If
End If
Next i
If Not rngUnion Is Nothing Then
rngUnion.Copy
Windows("Test.xlsm").Activate
With Rows("11:11")
.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End With
Application.CutCopyMode = False
End If
End Sub

Answer 2

The reason this only pastes the last selected row is because you are not copying and pasting within the loop. If you move the Selection.Copy/Paste within the loop the code should work. A better way to do this would be to avoid copying and pasting entirely and directly set the values of the rows. See code below:
Dim i As Integer
For i = 6 To lines + 6
color1 = Cells(i, 21).Value
color2 = Cells(i, 22).Value
If IsNumeric(Cells(i, 21)) Then
Select Case color1 & color2
Case Evaluate("=White") & Evaluate("=Blue"):
Workbooks("Test").Sheets("Sheet1").Rows(i).Value = _
Workbooks("01 January").Sheets("Sheet1").Rows(i).Value
...
End Select
End If
Next i
You can just update the sheet or workbook names as necessary but this method is substantially faster than copying and pasting.

Answer 3

should you have a large number of rows to be copied and paste it's safer not to rely neither on Union() nor Address() methods and switch to a "helper" column where to first mark the row for copying and then copy and paste in one shot. This is also much faster then the two methods above
you can also take advantage of SpecialCells() method to filter "numeric" cells only:
Dim lines As Long
Dim cell As Range
Workbooks.Open Filename:="D:\01 January.xlsm", UpdateLinks:=0
lines = WorksheetFunction.CountA(Range("U:U")) - 1
With Range(Cells(6, "U"), Cells(lines + 6, "U")) '<--| reference your relevant range in column "U"
For Each cell In .SpecialCells(xlCellTypeConstants, xlNumbers) '<--| loop through "numeric" cells only
Select Case cell.Value & cell.Offset(, 1).Value
Case Evaluate("=White") & Evaluate("=Blue"), Evaluate("=Yellow") & Evaluate("=Yellow"), Evaluate("=Yellow") & Evaluate("=Green")
cell.Offset(, 2).Value = 1 '<--| mark row for copying&pasting
End Select
Next
With .Offset(, 2) '<-- consider column "W" cells corresponding to referenced cells
If WorksheetFunction.CountA(.Cells) > 0 Then '<--| if there's at least one row marked for copy&paste
.SpecialCells(xlCellTypeConstants, xlNumbers).EntireRow.Copy '<--| copy all marked rows
With Workbooks("Test.xlsm").ActiveSheet.Rows("11:11") '<--| reference target range
.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End With
Application.CutCopyMode = False '<--| clear clipboard
End If
.ClearContents '<--| clear "helper" column
End With
End With