Copy yellow fill colored items after last row containing items

[howard]

I have items in Col A to D on sheet6


where the items have a yellow fill color in Col D, then all the rows (Col A:D) are to be copied and pasted on sheet7 in Col A, but these items are to be posted in the last row after the last item in Col D on sheet7


I need this part of the code amended as it is not pasting after the last item in Col D

       wNew.Range("A" & j).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues

See full code below

 Sub CopyCOSYellowItems()
  Sheets(6).Select
  Dim LR As Long
  LR = Cells(Rows.Count, "A").End(xlUp).Row
  
  
  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("A" & j).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
        j = j + 1
    
    End If
  Next
  
  
  Application.CutCopyMode = False
  Sheets(7).Select
    Range("A1").EntireRow.Insert
    Range("D2:D" & LR).NumberFormat = "#,##0;(#,##0)"
    
    Range("A:D").EntireColumn.AutoFit
    
    
      
     wks.Range("a1:D1").Copy
     wNew.Range("A1").PasteSpecial Paste:=xlPasteValues
      
  Application.CutCopyMode = False
  
End Sub

It would be appreciated if someone could kindly assist me

I have also posted on the link below

https://www.excelforum.com/excel-pr...items-where-col-d-has-fill-colured-items.html

 

[footoo]

Maybe this :

wNew.Range("D" & Rows.Count).End(xlUp).Offset(1, -3).PasteSpecial Paste:=xlPasteValues

In which case, j can be eliminated from the macro.

 

[howard]

Thanks code works perfectly

 

[howard]

I tried to amend code so that I pastes the data 2 rows after the last row where there is data in Col D, but it pastes the data in every second row

 wNew.Range("D" & Rows.Count).End(xlUp).Offset(2, -3).PasteSpecial Paste:=xlPasteValues

 

[footoo]

I tried to amend code so that I pastes the data 2 rows after the last row where there is data in Col D, but it pastes the data in every second row

 wNew.Range("D" & Rows.Count).End(xlUp).Offset(2, -3).PasteSpecial Paste:=xlPasteValues

Do you mean that you want to leave one empty row after the last data row in Col D?

 

[howard]

Yes, I want to leave one empty row after the last data row in Col D

 

[footoo]

Dim j As Long
j = 2
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

 

[howard]

Thanks for the help much appreciated