CODEWITHSUNDEEP
vbaexcel
sc1324
sc1324

Reputation: 600

vba - Shading entire row based on date

Each week I get new data and I m filtering for for "n/a" column from another sheet and grabbing the rest of the columns and adding them to my existing sheet of the same workbook and I need to color the rows that have dates smaller than tomorrow's date, so today or prior. New data range varies each week and I only want to color new data. I am checking dates using column D and there are also dates in column C so I don't know if that will complicate the task.

I know this can be achieved using conditional formatting, but I want to use vba codes to automate the process.

My codes won't work since it can't determine where my new data starts and only colors column D not the whole row if it fits the criteria. Please see my codes and my desire result.

 Sub paste_value()
   Dim ws1, ws2 As Worksheet
   Dim lr1, lr2 As Long
   Dim rCell As Range
   'filter
   Set ws1 = Worksheets("All Renewals_V2")
   Set ws2 = Worksheets("Renewal policies")
   lr1 = ws1.Cells(Rows.Count, "B").End(xlUp).Row
   lr2 = ws2.Cells(Rows.Count, "A").End(xlUp).Row
   'copy range from column B to column R
   With ws1.Range("B2", "R" & lr1)
   .AutoFilter Field:=1, Criteria1:="#N/A"
   'paste result from column A
   .Copy Destination:=Cells(lr2, "A")
   End With
  For Each rCell In .Range("D5", .Cells(.Rows.Count, 4).End(xlUp)).Cells
  If rCell.Value <= Date + 1 Then
  rCell.Interior.color = vbYellow
  End If
    Next rCell
 End Sub

enter image description here

Upvotes: 1

Views: 1599

Answers (1)

YowE3K
YowE3K

Reputation: 23994

If I am understanding your question correctly, I think the following modifications to your code will enable it to work:

Sub paste_value()
    'Dim ws1, ws2 As Worksheet
    'Dim lr1, lr2 As Long
    'existing code declared ws1 and lr1 as Variants
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim lr1 As Long, lr2 As Long
    Dim rCell As Range
    'filter
    Set ws1 = Worksheets("All Renewals_V2")
    Set ws2 = Worksheets("Renewal policies")
    'lr1 = ws1.Cells(Rows.Count, "B").End(xlUp).Row
    'Should qualify which sheet "Rows" refers to
    lr1 = ws1.Cells(ws1.Rows.Count, "B").End(xlUp).Row
    'lr2 = ws2.Cells(Rows.Count, "A").End(xlUp).Row
    'Need to add 1 or else the first row of this week will replace the last
    'row of last week
    lr2 = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row + 1
    'copy range from column B to column R
    With ws1.Range("B2", "R" & lr1)
        .AutoFilter Field:=1, Criteria1:="#N/A"
        'paste result from column A
        '.Copy Destination:=Cells(lr2, "A")
        'Should specify that ws2 is the sheet to which "Cells" refers
        .Copy Destination:=ws2.Cells(lr2, "A")
    End With
    'I am guessing that the following statement is missing
    With ws2
        'For Each rCell In .Range("D5", .Cells(.Rows.Count, 4).End(xlUp)).Cells
        'Need to start the colouring from the first row pasted in
        For Each rCell In .Range("D" & lr2, .Cells(.Rows.Count, 4).End(xlUp)).Cells
            If rCell.Value <= Date + 1 Then
                'rCell.Interior.color = vbYellow
                'Change as per Scott Holtzman's comment
                rCell.Offset(, -3).Resize(1, 5).Interior.Color = vbYellow
                'Or an alternate version would be
                '  rCell.EntireRow.Columns("A:E").Interior.Color = vbYellow
                'Use whichever version makes the most sense to you
            End If
        Next rCell
    End With
End Sub

Upvotes: 1

Related Questions