Search code examples
vbaexcelmultiple-columnscopy-paste

Copy rows only if cells are not blank in selected columns


Below code (Code One) is currently working fine, where selected columns are copy & pasted with single criteria in Column A.

However, I am trying to add another condition, where excel will not copy cells if Columns N to R are blank. I tried writing Code Two (below) but getting Run-time error '9' Subscript out of Range.

Can I please get some assistance in changing Code Two so it will filter the columns correctly.

Code One

Dim i As Long
Dim iLastRow As Long
Dim iTarget As Long

With Worksheets("Okay")

    iLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    For i = 1 To iLastRow
        If .Cells(i, "A").Value = "Welcome" Then
            iTarget = iTarget + 1
            .Cells(i, "B").Copy
            Worksheets("Sheet7").Range("A" & iTarget + 1).PasteSpecial xlPasteValues
            .Cells(i, "C").Copy
            Worksheets("Sheet7").Range("B" & iTarget + 1).PasteSpecial xlPasteValues
            .Cells(i, "D").Copy
            Worksheets("Sheet7").Range("C" & iTarget + 1).PasteSpecial xlPasteValues
            .Cells(i, "E").Copy
            Worksheets("Sheet7").Range("D" & iTarget + 1).PasteSpecial xlPasteValues
            .Cells(i, "F").Copy
            Worksheets("Sheet7").Range("F" & iTarget + 1).PasteSpecial xlPasteValues
            Worksheets("Sheet7").Range("G" & iTarget + 1).Value = "How"
            Worksheets("Sheet7").Range("H" & iTarget + 1).Value = "Are"
            Worksheets("Sheet7").Range("I" & iTarget + 1).Value = "You"
            Worksheets("Sheet7").Range("J" & iTarget + 1).Value = "Okay"
            .Cells(i, "N").Copy
            Worksheets("Sheet7").Range("K" & iTarget + 1).PasteSpecial xlPasteValues
            .Cells(i, "O").Copy
            Worksheets("Sheet7").Range("L" & iTarget + 1).PasteSpecial xlPasteValues
            .Cells(i, "P").Copy
            Worksheets("Sheet7").Range("M" & iTarget + 1).PasteSpecial xlPasteValues
            .Cells(i, "Q").Copy
            Worksheets("Sheet7").Range("N" & iTarget + 1).PasteSpecial xlPasteValues
            .Cells(i, "R").Copy
            Worksheets("Sheet7").Range("O" & iTarget + 1).PasteSpecial xlPasteValues
        End If
    Next i

End With

Code Two

Dim i As Long
Dim iLastRow As Long
Dim iTarget As Long

With Worksheets("Okay")

    iLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    For i = 1 To iLastRow
        If .Cells(i, "A").Value = "Welcome" Then
        If .Cells(i, "N").Value <> "" Then
        If .Cells(i, "O").Value <> "" Then
        If .Cells(i, "P").Value <> "" Then
        If .Cells(i, "Q").Value <> "" Then
        If .Cells(i, "R").Value <> "" Then
            iTarget = iTarget + 1
            .Cells(i, "B").Copy
            Worksheets("Sheet7").Range("A" & iTarget + 1).PasteSpecial xlPasteValues
            .Cells(i, "C").Copy
            Worksheets("Sheet7").Range("B" & iTarget + 1).PasteSpecial xlPasteValues
            .Cells(i, "D").Copy
            Worksheets("Sheet7").Range("C" & iTarget + 1).PasteSpecial xlPasteValues
            .Cells(i, "E").Copy
            Worksheets("Sheet7").Range("D" & iTarget + 1).PasteSpecial xlPasteValues
            .Cells(i, "F").Copy
            Worksheets("Sheet7").Range("F" & iTarget + 1).PasteSpecial xlPasteValues
            Worksheets("Sheet7").Range("G" & iTarget + 1).Value = "Hello"
            Worksheets("Sheet7").Range("H" & iTarget + 1).Value = "How"
            Worksheets("Sheet7").Range("I" & iTarget + 1).Value = "Are"
            Worksheets("Sheet7").Range("J" & iTarget + 1).Value = "You"
            .Cells(i, "N").Copy
            Worksheets("Sheet7").Range("K" & iTarget + 1).PasteSpecial xlPasteValues
            .Cells(i, "O").Copy
            Worksheets("Sheet7").Range("L" & iTarget + 1).PasteSpecial xlPasteValues
            .Cells(i, "P").Copy
            Worksheets("Sheet7").Range("M" & iTarget + 1).PasteSpecial xlPasteValues
            .Cells(i, "Q").Copy
            Worksheets("Sheet7").Range("N" & iTarget + 1).PasteSpecial xlPasteValues
            .Cells(i, "R").Copy
            Worksheets("Sheet7").Range("O" & iTarget + 1).PasteSpecial xlPasteValues
            .Cells(i, "G").Copy
            Worksheets("Sheet7").Range("P" & iTarget + 1).PasteSpecial xlPasteValues
        End If
        End If
        End If
        End If
        End If
        End If
    Next i

End With

Solution

  • If you are getting a "subscript out of range" error on the line

    Worksheets("Sheet7").Range("A" & iTarget + 1).PasteSpecial xlPasteValues
    

    then the most likely reason (or, I think, the only reason) is that you don't have a worksheet called "Sheet7".


    Note: You can improve your code by not using Copy/Paste. Copy/Paste is slow, and it can also lead to issues if your users perform another manual copy/paste in some other application while they are waiting for your macro to run. Try this slightly refactored code:

    Dim i As Long
    Dim iLastRow As Long
    Dim iTarget As Long
    iTarget = 1 ' initialise value to avoid lots of "+ 1"s
    
    With Worksheets("Okay")    
        iLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        For i = 1 To iLastRow
            If .Cells(i, "A").Value = "Welcome" Then
            If .Cells(i, "N").Value <> "" Then
            If .Cells(i, "O").Value <> "" Then
            If .Cells(i, "P").Value <> "" Then
            If .Cells(i, "Q").Value <> "" Then
            If .Cells(i, "R").Value <> "" Then
                iTarget = iTarget + 1
                'Set 4 columns at once
                Worksheets("Sheet7").Range("A" & iTarget).Resize(1, 4).Value = .Cells(i, "B").Resize(1, 4).Value
                Worksheets("Sheet7").Range("F" & iTarget).Value = .Cells(i, "F").Value
                Worksheets("Sheet7").Range("G" & iTarget).Value = "Hello"
                Worksheets("Sheet7").Range("H" & iTarget).Value = "How"
                Worksheets("Sheet7").Range("I" & iTarget).Value = "Are"
                Worksheets("Sheet7").Range("J" & iTarget).Value = "You"
                'Set 5 columns at once
                Worksheets("Sheet7").Range("K" & iTarget).Resize(1, 5).Value = .Cells(i, "N").Resize(1, 5).Value
                Worksheets("Sheet7").Range("P" & iTarget).Value = .Cells(i, "G").Value
            End If
            End If
            End If
            End If
            End If
            End If
        Next i    
    End With