Question

每周我都会获得新数据，并且我正在过滤＆＃34; n / a＆＃34;从另一个工作表中删除列并抓住其余列并将其添加到同一工作簿的现有工作表中，我需要为日期小于明天的日期，即今天或之前的行着色。新的数据范围每周都有所不同，我只想为新数据着色。我正在使用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

vba - 根据日期着色整行

1 个答案: