查询停发续发情况

lrh788 · 发表于 2020-7-21 22:17

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

老师，我把你的停发续发代码加载到我的原表中运行就提取出错了。详见附件，你运行代码看下就可以发现问题

lrh788 · 发表于 2020-7-21 22:55

停发和续发的次数是正确的，但提取的停发或续发的时间就不正确了

笨鸟飞不高 · 发表于 2020-7-22 00:11

lrh788 发表于 2020-7-21 22:55
停发和续发的次数是正确的，但提取的停发或续发的时间就不正确了

代码都被你修改了。。。。

lrh788 · 发表于 2020-7-22 07:03

本帖最后由 lrh788 于 2020-7-22 07:09 编辑

笨鸟飞不高发表于 2020-7-22 00:11
代码都被你修改了。。。。

老师，先前是我把附件发错了，但是没有修改“停发续发”代码，我重新上传了附件，请看下原因？

lrh788 · 发表于 2020-7-22 07:24

本帖最后由 lrh788 于 2020-7-23 16:41 编辑

笨鸟飞不高发表于 2020-7-22 00:11
代码都被你修改了。。。。

老师，我发现问题原因了，是你的停发续发代码中两处出错了，我在新的附件中修改If n = 8 Then取值就正确了。还请老师修改代码能自动识别数据列数，我原表15列，但我修改成If n = 15 Then取值仍不正确。
               If n = 7 Then
                        ym1 = arr(i, 3)
                        brr(r, n) = 1 & "次" & "(" & ym1 & ")"
                     Else
                        ym2 = arr(i, 3)
                        brr(r, n) = 1 & "次" & "(" & ym2 & ")"
                     End If
                  Else
                     k = d(iStr & "|" & "mark")
                      For j = 1 To 7
                        brr(k, j) = arr(i, j)
                     Next

笨鸟飞不高 · 发表于 2020-7-22 08:11

lrh788 发表于 2020-7-22 07:03
老师，先前是我把附件发错了，但是没有修改“停发续发”代码，我重新上传了附件，请看下原因？

Sub AwDemo2()
Dim i&, j%, n%, r&, k&, m%, s%, x%, y%, ym1$, ym2$, iStr$
Dim arr, kAr, tAr, begDay$, endDay$, 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("数据")
      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
      kAr = d.keys: tAr = d.items
      ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2) + 2)
      For j = 1 To UBound(arr, 2)
         brr(1, j) = arr(1, j)
      Next
      brr(1, UBound(brr, 2) - 1) = "停发次数"
      brr(1, UBound(brr, 2)) = "续发次数"
      r = 1
      For i = 2 To UBound(arr)
         If arr(i, 3) >= begDay And arr(i, 3) <= endDay Then
            iStr = arr(i, 1) & "|" & arr(i, 2)
            x = Split(d(iStr), "|")(0): y = Split(d(iStr), "|")(1)
            If arr(i, 4) = "停发" Then n = UBound(brr, 2) - 1 Else n = UBound(brr, 2)
            If x <> Abs(y) Then
                  If Not d.exists(iStr & "|" & "mark") Then
                     ym1 = "": ym2 = ""
                     r = r + 1
                     d(iStr & "|" & "mark") = r
                     For j = 1 To UBound(arr, 2)
                        brr(r, j) = arr(i, j)
                     Next
                     d(iStr & "|" & arr(i, 4)) = 1
                     If n = UBound(brr, 2) - 1 Then '这句修改一下
                        ym1 = arr(i, 3)
                        brr(r, n) = 1 & "次" & "(" & ym1 & ")"
                     Else
                        ym2 = arr(i, 3)
                        brr(r, n) = 1 & "次" & "(" & ym2 & ")"
                     End If
                  Else
                     k = d(iStr & "|" & "mark")
                     For j = 1 To UBound(arr, 2)
                        brr(k, j) = arr(i, j)
                     Next
                        d(iStr & "|" & arr(i, 4)) = d(iStr & "|" & arr(i, 4)) + 1
                        m = d(iStr & "|" & arr(i, 4))
                        If n = UBound(brr, 2) - 1 Then '这句修改一下
                              ym1 = ym1 & "," & arr(i, 3)
                              brr(k, n) = m & "次" & "(" & ym1 & ")"
                        Else
                              ym2 = ym2 & "," & arr(i, 3)
                              brr(k, n) = m & "次" & "(" & ym2 & ")"
                        End If
                  End If
            End If
         End If
      Next
End With
With Sheets("停发续发")
      .Cells.Clear
      If r > 0 Then
         .[a1].Resize(r, UBound(brr, 2)) = brr
      End If
End With
Application.ScreenUpdating = True
End Sub

lrh788 · 发表于 2020-7-22 08:54

本帖最后由 lrh788 于 2020-7-22 10:08 编辑

笨鸟飞不高发表于 2020-7-22 08:11
Sub AwDemo2()
Dim i&, j%, n%, r&, k&, m%, s%, x%, y%, ym1$, ym2$, iStr$
Dim arr, kAr, tA ...

谢谢老师，修改后的代码在原表中已取值正确了

lrh788 · 发表于 2020-7-22 10:27

本帖最后由 lrh788 于 2020-7-22 10:39 编辑

笨鸟飞不高发表于 2020-7-22 08:11
Sub AwDemo2()
Dim i&, j%, n%, r&, k&, m%, s%, x%, y%, ym1$, ym2$, iStr$
Dim arr, kAr, tA ...

lrh788 · 发表于 2020-7-23 15:57

笨鸟飞不高发表于 2020-7-22 08:11
Sub AwDemo2()
Dim i&, j%, n%, r&, k&, m%, s%, x%, y%, ym1$, ym2$, iStr$
Dim arr, kAr, tA ...

老师，再次烦请您改动下代码达到附件中停发续发表中效果（把停发次数与停发年月、续发次数与续发年月分开，便于筛选处理）。另外请解释下面代码标红部分（num、sum、mark、abs）的意思。
d(iStr & "|" & "Num") = d(iStr & "|" & "Num") + 1
d(iStr & "|" & "Sum") = d(iStr & "|" & "Sum") + s

If Not d.exists(iStr & "|" & "mark") Then
x = Split(d(iStr), "|")(0): y = Split(d(iStr), "|")(1)
If arr(i, 4) = "停发" Then n = UBound(brr, 2) - 1 Else n = UBound(brr, 2)
If x <> Abs(y) Then

zpy2 · 发表于 2020-7-23 18:05

lrh788 发表于 2020-7-23 15:57
老师，再次烦请您改动下代码达到附件中停发续发表中效果（把停发次数与停发年月、续发次数与续发年月分开 ...

能不能数据量小点，模拟一下结果

我觉得就是某人停放>0 并且须发>0 同时满足这二个条件的记录筛选出来对吗？

		自动登录	找回密码
密码			免费注册

[求助] 查询停发续发情况

评分

浏览过的版块