VBA how to copy paste specific cells if condition is met, not all row

[aksent1344]

I have a code to copy paste entire row which met condition, but how to copy not entire row, but specific cells from that rows? For example just A, C and D cells from row.

Sub CopyRow_Item()
Application.ScreenUpdating = False
Dim LastRow As Long
Dim last_row As Long
Item = ThisWorkbook.Sheets("Sheet1").Range("B1").Value
LastRow = Sheets("Actuals").Cells.Find("*", SearchOrder:=xlByRows,
SearchDirection:=xlPrevious).Row
last_row = Cells(Rows.Count, "A").End(xlUp).Row
Dim x As Long
x = 1
Dim rng As Range
For Each rng In Sheets("Actuals").Range("A2:A" & LastRow)
If rng = Item Then
rng.EntireRow.Copy
Sheets("Sheet1").Cells(last_row + x, 1).PasteSpecial xlPasteValues
x = x + 1
End If
Next rng


Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

 

[aksent1344]

Try:

Sub CopyData()
    Application.ScreenUpdating = False
    Dim srcWS As Worksheet, desWS As Worksheet, fnd As Range, colArr As Variant, i As Long
    colArr = Array("A", "A", "B", "E", "I", "O", "K", "M", "M", "L")
    Set desWS = Sheets("Sheet1")
    Set srcWS = Sheets("Sheet3")
    Set fnd = srcWS.Range("A:A").Find(desWS.Range("B1").Value, LookIn:=xlValues, lookat:=xlWhole)
    If Not fnd Is Nothing Then
        For i = LBound(colArr) To UBound(colArr) Step 2
            srcWS.Range(colArr(i) & fnd.Row).Copy desWS.Cells(desWS.Rows.Count, colArr(i + 1)).End(xlUp).Offset(1)
        Next i
    Else
        MsgBox desWS.Range("B1") & " not found."
    End If
    Application.ScreenUpdating = True
End Sub

Yes, it worked!!! Thank you so much!

 

[mumps]

You are very welcome.

 

[aksent1344]

Maybe you can add what need to be changed that it paste just values without yellow color?

 

[aksent1344]

Found it