查询停发续发情况

笨鸟飞不高

lrh788 发表于 2020-7-19 06:46
谢谢笨鸟飞不高 老师的帮助，你的代码已基本符合要求了，只是对同一人存在多次停发且未有任何续发的人员 ...

停发或续发人员效果.rar (1.68 MB, 下载次数: 12)

2020-7-19 11:24 上传

点击文件名下载附件

重新换个思路写了个代码！发现和前一次数据有差异！没去验证，也不知道对不对！！！

lrh788

丸子不是小孩子 发表于 2020-7-19 10:27
哈哈，我看到有人写就不写了

还请老师再辛苦下，写下代码？

lrh788

笨鸟飞不高 发表于 2020-7-19 11:26
重新换个思路写了个代码！发现和前一次数据有差异！没去验证，也不知道对不对！！！

谢谢老师，我在外面没法测试，待回来后再测试。

lrh788

笨鸟飞不高 发表于 2020-7-19 11:26
重新换个思路写了个代码！发现和前一次数据有差异！没去验证，也不知道对不对！！！

老师，我暂未发现你的代码运行结果不对之处，只是你的一直停发代码对重复停发无读发人员未进行标注。谢谢老师了！

lrh788

丸子不是小孩子 发表于 2020-7-19 00:09
已更新代码，更新代码在模块2，原代码保留在模块1，更新内容
1、统计起止年月合并在同一输入框
2、除ABC ...

老师，还请你把第二个代码写下，便于我判断结果是否正确。因为数据量大，我也无标准结果。

笨鸟飞不高

lrh788 发表于 2020-7-19 22:46
老师，我暂未发现你的代码运行结果不对之处，只是你的一直停发代码对重复停发无读发人员未进行标注

If Not rng Is Nothing Then rng.Interior.Color = vbRed。。。
数据表姓名列有填充色。。。

lrh788

笨鸟飞不高 发表于 2020-7-19 22:56
If Not rng Is Nothing Then rng.Interior.Color = vbRed。。。
数据表姓名列有填充色。。。

老师，，我才看到你标注到数据表中了，我的意思是在一直停发表中进行标注，不是在数据表中标注。我没有发现和前一次数据有差异?你是指哪个地方有差异。

笨鸟飞不高

lrh788 发表于 2020-7-20 08:39
老师，，我才看到你标注到数据表中了，我的意思是在一直停发表中进行标注，不是在数据表中标注。我没有发 ...

一直停发表中标记也可以，不过一直停发表是根据日期段筛选的结果，有些重复停发无续发的人员不能在这里体现
Sub AwDemo()
    Dim i&, r&, j%, s%, x%, y%, DayM%, iStr$, DayStr$, begDay$, endDay$
    Dim iDay As Date, rng As Range, arr, d As Object
    Application.ScreenUpdating = False
    Set d = CreateObject("Scripting.Dictionary")
    begDay = InputBox("请输入开始日期，格式如：202001")
    If StrPtr(begDay) = 0 Then Exit Sub
    endDay = InputBox("请输入结束日期，格式如：202001")
    If StrPtr(endDay) = 0 Then Exit Sub
    With Sheets("数据")
        .[a1:f83015].Sort .[a1], , .[c1], , Header:=xlYes
        arr = .[a1].CurrentRegion
        For i = 2 To UBound(arr)
            If arr(i, 4) = "停发" Then s = -1 Else s = 1
            iStr = arr(i, 1) & "|" & arr(i, 2)
            d(iStr & "|" & "Num") = d(iStr & "|" & "Num") + 1
            d(iStr & "|" & "Sum") = d(iStr & "|" & "Sum") + s
            d(iStr) = d(iStr & "|" & "Num") & "|" & d(iStr & "|" & "Sum")
        Next
        ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2) + 1)
        For j = 1 To UBound(arr, 2)
            brr(1, j) = arr(1, j)
        Next
        brr(1, UBound(brr, 2)) = "停发年次"
        r = 1
        For i = 2 To UBound(arr)
            iStr = arr(i, 1) & "|" & arr(i, 2)
            x = Split(d(iStr), "|")(0): y = Split(d(iStr), "|")(1)
            If arr(i, 3) >= begDay And arr(i, 3) <= endDay Then
                If x = Abs(y) And y < 0 Then
                    r = r + 1
                    For j = 1 To UBound(arr, 2)
                        brr(r, j) = arr(i, j)
                    Next
                    DayStr = Left(brr(r, 3), 4) & "-" & Right(brr(r, 3), 2)
                    iDay = CDate(DayStr)
                    DayM = DateDiff("m", iDay, CDate(Left(endDay, 4) & "-" & Right(endDay, 2)))
                    If DayM > 0 Then brr(r, UBound(brr, 2)) = DayM \ 12 & "年" & DayM Mod 12 & "个月"
                End If
            End If
        Next
    End With
    With Sheets("一直停发")
        .Cells.Clear
        If r > 0 Then
            .[a1].Resize(r, UBound(brr, 2)) = brr
            .[a1].CurrentRegion.Interior.ColorIndex = 0
            arr = .[a1].CurrentRegion
            For i = 2 To UBound(arr)
                iStr = arr(i, 1) & "|" & arr(i, 2)
                x = Split(d(iStr), "|")(0): y = Split(d(iStr), "|")(1)
                If x = Abs(y) And x > 1 Then
                    If rng Is Nothing Then
                        Set rng = .Cells(i, 2)
                    Else
                        Set rng = Union(rng, .Cells(i, 2))
                    End If
                End If
            Next
            If Not rng Is Nothing Then rng.Interior.Color = vbRed
        End If
    End With
    Application.ScreenUpdating = True
End Sub

lrh788

笨鸟飞不高 发表于 2020-7-20 09:34
一直停发表中标记也可以，不过一直停发表是根据日期段筛选的结果，有些重复停发无续发的人员不能在这里体 ...

谢谢老师，此代码已经符合要求了，不知你先前说的哪个地方有差异。

lrh788

烦请丸子老师在空时把第二个代码写下。