vba - 根據日期對整行進行着色

Question

每週我都會得到新的數據，並從另一張表格的「n/a」列過濾並獲取其餘列並將它們添加到我現有的同一工作簿我需要給日期小於明天日期的行着色，所以今天或之前。新的數據範圍每週都有所不同，我只想塗上新的數據。我使用D列檢查日期，C列中也有日期，所以我不知道這是否會使任務複雜化。

我知道這可以使用條件格式來實現，但我想使用vba代碼來自動化該過程。

我的代碼不起作用，因爲它不能確定我的新數據在哪裏開始，並且只有在列D符合條件時才顯示整行。請看我的代碼和我的願望結果。

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 

Answer 1

如果我正確地理解你的問題，我認爲以下修改你的代碼將使它的工作：

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