Forum Discussion

clh_1496's avatar
clh_1496
Brass Contributor
Aug 09, 2023

VBA to copy row but only those cells in certain columns

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

 

  • 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

Share