CODEWITHSUNDEEP
vbaexcel
Jay
Jay

Reputation: 47

Copy Row over to another sheet with multiple criteria in multiple ranges VBA Excel

I am trying to copy rows from one sheet to another using VBA, I need it to check cell in column a if it contains value X and if column C excludes Value Y.

I have come as far to copy it with the first criteria, but not the second.

This is what I have and it won't work...

Sub Copy_2016()
'
'Run Sub Copy_2016()
'
Sheets("Working - 2016").Select
Range("A3:AO6304").ClearContents

For Each Cell In Sheets("Working - Data").Range("A1:A6304,C3:C6304")
    If Cell.Value = "2016" And If Not Cell.Value = "HI" Then
         matchRow = Cell.Row
         Rows(matchRow & ":" & matchRow).Select
         Selection.Copy

         Sheets("Working - 2016").Select
         ActiveSheet.Rows(matchRow).Select
         ActiveSheet.Paste
         Sheets("Working - Data").Select
    End If
Next

End Sub

Upvotes: 1

Views: 1774

Answers (2)

Shai Rado
Shai Rado

Reputation: 33672

One thing @chris neilsen answer is missing, is that the pasted sheet ("Working - 2016") will have blank rows in the middle (since not all rows will be copied), that's why I added the RowDest variable.

Also, if all you do is paste the values, you can use Worksheets("Working - 2016").Rows(RowDest).value = Cell.EntireRow.value instead of Copy and PasteSpecial in 2 code lines.

Code

Option Explicit

Sub Copy_2016()

    Dim Cell As Range
    Dim RowDest As Long

    With Worksheets("Working - 2016")
        .Range("A3:AO6304").ClearContents
    End With

    RowDest = 3 ' first paste row , since you are clearing the sheet's contents
    With Worksheets("Working - Data")
        For Each Cell In .Range("A1:A6304")
            If Cell.value Like "2016" And Not Cell.Offset(0, 2).value Like "HI" Then
                Worksheets("Working - 2016").Rows(RowDest).value = Cell.EntireRow.value
                RowDest = RowDest + 1
            End If
        Next Cell
    End With

End Sub

Upvotes: 1

chris neilsen
chris neilsen

Reputation: 53135

I think you need something like this

Sub Copy_2016()
    Dim Cell As Range
    Worksheets("Working - 2016").Range("A3:AO6304").ClearContents

    For Each Cell In Worksheets("Working - Data").Range("A1:A6304")
        If Cell.Value = "2016" And Not Cell.Offset(0, 2).Value = "HI" Then
            Cell.EntireRow.Copy
            Worksheets("Working - 2016").Rows(Cell.Row).PasteSpecial Paste:=xlPasteValues
        End If
    Next
End Sub

Upvotes: 1

Related Questions