Copy Data on sheet6 based on yellow colour

[howard]

I have data that is in yellow in Col D on sheet6

Where this is the then the item in Col A:D where there are yellow items are to be copied into A2 onwards

I have written code to do this, except that it is copying this after the last row containing data


I need this amended as I need this copied in row 2 onwards.


Kindly amend my code so it copies the data into row2 onwards and not after the last row containing data

Your assistance is most appreciated

 Sub CopyCOSYellowItems()

Application.ScreenUpdating = False
  

  Sheets(7).Select
  Range("A2").Select
  
  
  Dim wks As Worksheet
  Dim wNew As Worksheet
  Dim lRow As Long
  Dim x As Long
  Dim j As Long
j = 1
Set wks = Sheets(6)
  lRow = wks.Cells.SpecialCells(xlCellTypeLastCell).Row
  Set wNew = Sheets(7)
For x = 2 To lRow
  If wks.Cells(x, 4).Interior.Color = vbYellow Then
      wks.Range("A" & x & ":D" & x).Copy
      wNew.Range("D" & Rows.Count).End(xlUp).Offset(j, -3).PasteSpecial Paste:=xlPasteValues
     ' j = 1
  End If
Next
  
  
  
  Application.CutCopyMode = False
 ' Sheets(7).Select
  'If Range("A1") = "Branch" Then
  'End If
  'Exit Sub
  
  
  
    wks.Range("a1:D1").Copy
     wNew.Range("A1").PasteSpecial Paste:=xlPasteValues
      
  Application.CutCopyMode = False

  Application.ScreenUpdating = True

End Sub

 

[onlyadrafter]

Hello,

does this work as expected?

Sub CopyCOSYellowItems()
    Application.ScreenUpdating = False
    Sheets(7).Select
    Range("A2").Select
    Dim wks As Worksheet
    Dim wNew As Worksheet
    Dim lRow As Long
    Dim x As Long
    Dim j As Long
    j = 1
    Set wks = Sheets(6)
    lRow = wks.Cells.SpecialCells(xlCellTypeLastCell).Row
    Set wNew = Sheets(7)
    MY_COUNT = 2
    For x = 2 To lRow
        If wks.Cells(x, 4).Interior.Color = vbYellow Then
            wks.Range("A" & x & ":D" & x).Copy
            wNew.Range("D" & MY_COUNT).PasteSpecial Paste:=xlPasteValues
            MY_COUNT = MY_COUNT + 1
         ' j = 1
        End If
    Next
    Application.CutCopyMode = False
    ' Sheets(7).Select
    'If Range("A1") = "Branch" Then
    'End If
    'Exit Sub
    wks.Range("a1:D1").Copy
    wNew.Range("A1").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

 

[howard]

Thanks for the help. Your code work perfectly