VBA to copy row but only those cells in certain columns

[clh_1496]

Hi,

I've got a line of VBA that looks for the word Check in column E and then copies the rows that match this criteria:

For Each Cell In Workbooks(1).Worksheets("PBS").Range("E:E")
rw = Cell.Row
If Cell.Value = "CHECK" Then
Cell.EntireRow.Copy
Workbooks(1).Worksheets("CHECK").Range("A" & rw).End(xlUp).Offset(1). _
PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False

However, what I want to do is only copy the cells in columns A,C:D of each row that contains the word Check in column E?

Kind regards

Charlotte

[#2]

@clh_1496 

Try this:

Sub CopyCells()
    Dim PBS As Worksheet
    Dim CHECK As Worksheet
    Dim Cell As Range
    Dim Addr As String
    Dim Target As Range
    Application.ScreenUpdating = False
    Set PBS = Worksheets("PBS")
    Set CHECK = Worksheets("CHECK")
    Set Target = CHECK.Range("A" & CHECK.Rows.Count).End(xlUp)
    Set Cell = PBS.Range("E:E").Find(What:="CHECK", LookAt:=xlWhole)
    If Not Cell Is Nothing Then
        Addr = Cell.Address
        Do
            Set Target = Target.Offset(1)
            Target.Resize(1, 3).Value = Array( _
                Cell.Offset(0, -4).Value, _
                Cell.Offset(0, -2).Value, _
                Cell.Offset(0, -1).Value)
            Set Cell = PBS.Range("E:E").Find(What:="CHECK", After:=Cell, LookAt:=xlWhole)
            If Cell Is Nothing Then Exit Sub
        Loop Until Cell.Address = Addr
    End If
    Application.ScreenUpdating = True
End Sub