Copy specific Rows from one workbook to another

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

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

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

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