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