VBA如何实现这样的自动填充底色效果

SCWYZJ

求助：在工作中发现商品有些标的是【生产日期】，有些标的是【有效日期】，这样就会在制表统计时非常不方便，房间很多商品也多，为了提高盘点统计效率，我自己设计了一张盘点表（见附件），想用VBA实现自动填色的的效果。烦请大神老师帮忙写写代码，如果能顺带统计出各商品的相应各底色数据更佳。谢谢，小花静候！

shiruiqiang

循环日期单元格，不为空的话，dateadd（“m”，，月数量，日期）和 now（）比较，datediff是否小于60或者为负数，标色

3190496160

Sub 填充()
Application.ScreenUpdating = False
Dim ar As Variant
Dim rn As Range, rng As Range
With Sheets("sheet1")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    y = .Cells(4, Columns.Count).End(xlToLeft).Column
    If r < 2 Then MsgBox "数据表为空！": End
    ar = .Range(.Cells(1, 1), .Cells(r, y))
    .Range(.Cells(6, 3), .Cells(r, y)).Interior.ColorIndex = 0
    For j = 3 To UBound(ar, 2)
        If Trim(ar(3, j)) = "" Then
            ar(3, j) = ar(3, j - 1)
        End If
        If Trim(ar(3, j)) <> "长期" Then
            ts = ar(3, j) * 30
            For i = 6 To UBound(ar)
                If Trim(ar(i, j)) <> "" Then
                    If IsDate(ar(i, j)) Then
                        ys = DateDiff("d", ar(i, j), Date)
                        If ts - ys <= 60 And ts - ys > 0 Then
                            If rn Is Nothing Then
                                Set rn = .Cells(i, j)
                            Else
                                Set rn = Union(rn, .Cells(i, j))
                            End If
                        ElseIf ys > ts Then
                            If rng Is Nothing Then
                                Set rng = .Cells(i, j)
                            Else
                                Set rng = Union(rng, .Cells(i, j))
                            End If
                        End If
                    End If
                End If
            Next i
        End If
    Next j
    If Not rn Is Nothing Then rn.Interior.ColorIndex = 6
    If Not rng Is Nothing Then rng.Interior.ColorIndex = 3
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

3190496160

结果未认真核对，代码仅供参考
VBA如何实现这样的填色效果.rar (18.04 KB, 下载次数: 14)

2023-6-2 16:04 上传

点击文件名下载附件

吴中泉

简单弄一个，还要优化

吴中泉

代码优化了一下，正确性还需你进一步验证

吴中泉

VBA如何实现这样的填色效果.rar (19.42 KB, 下载次数: 8)

2023-6-2 17:01 上传

点击文件名下载附件

SCWYZJ

3190496160 发表于 2023-6-2 16:04
结果未认真核对，代码仅供参考

老师，我试了下，生产日期没问题，有效日期列不行。怎么改代码。谢谢

SCWYZJ

吴中泉 发表于 2023-6-2 17:01

老师，我看了下，还是不行。代码还要改。蓝色日期没标注红色。