比对不一致重新标记

kort20034

之前的太啰嗦了，其实是能不能在过期后在大于过期日期的数据里重新标记一个，如下图，谢谢！

kort20034

就是在大于绿色底的过期时间的数据中重新标记一个这一步就可以了

taller

Option Explicit
Sub Demo()
    Dim objDic As Object, rngData As Range
    Dim i As Long, sKey As String, iCnt, MaxDate As Double
    Dim arrData
    Set objDic = CreateObject("scripting.dictionary")
    Set rngData = Sheets("Sheet2").Range("A1").CurrentRegion
    arrData = rngData.Value
    For i = LBound(arrData) + 1 To UBound(arrData)
        sKey = arrData(i, 1) & vbTab & arrData(i, 2)
        objDic(sKey) = ""
    Next i
    Set rngData = Sheets("Sheet1").Range("A1").CurrentRegion
    arrData = rngData.Value
    For i = UBound(arrData) To LBound(arrData) + 1 Step -1
        sKey = arrData(i, 1) & vbTab & arrData(i, 2)
        If objDic.exists(sKey) Then
            If arrData(i, 3) = "过期" Then ' 清理过期记录
                arrData(i, 5) = ""
                objDic.Remove sKey
                MaxDate = Application.Max(MaxDate, arrData(i, 4))
            End If
        End If
    Next i
    If objDic.Count < 10 Then
        For i = UBound(arrData) To LBound(arrData) + 1 Step -1
            ' 定位替补记录
            If arrData(i, 3) = "正常" And arrData(i, 5) = "" And CDbl(arrData(i, 2)) > MaxDate Then
                sKey = arrData(i, 1) & vbTab & arrData(i, 2)
                objDic(sKey) = ""
                arrData(i, 5) = 1
                If objDic.Count = 10 Then Exit For
            End If
        Next i
    End If
    rngData.Value = arrData
End Sub

taller

请楼主楼主核实模拟效果，按照规则第12和14行应该被标记

kort20034

taller 发表于 2024-11-17 11:53
请楼主楼主核实模拟效果，按照规则第12和14行应该被标记

啊？为啥是14行，14行的时间不是2024/8/30吗？应该小过2024/9/27 和2024/9/19这两个时间呀

taller

kort20034

taller 发表于 2024-11-17 11:53
请楼主楼主核实模拟效果，按照规则第12和14行应该被标记

我用Format 对比了一下，出来的数据是<=12行呀,格式应该没错吧

kort20034

taller 发表于 2024-11-17 12:09

谢谢哈！