求数据间隔及连续

cui26896

是论坛出故障了，我下载了1楼的附件到桌面，解压不了，没有反应。

cui26896

我现在再上传一个上来，你再下载一下，看行不行？
求数据间隔及连续.zip (13.12 KB, 下载次数: 4)

2020-5-24 18:29 上传

点击文件名下载附件

cui26896

YZC51 发表于 2020-5-24 17:10
老师好！好像都没有，4楼的附件好像与本主题无关！谢谢！

我刚上传了一个原附件，又下载到桌面，能解压。你再下载试试看。

q563262982

一把小刀闯天下 发表于 2020-5-23 18:11
'示例结果太少，以凑为主，，，

'-------------

小刀老师，非常感谢您的代码，但我发现有错误，主要出现在(最大间隔，上次连续间隔，当前连续间隔）,由于之前自己可能表达的不清楚，现重新模拟了答案，整理了第二版在1楼，请您参考下，答案区，红字标注的地方为答案有出入。

附件第二版在1楼。

YZC51

cui26896 发表于 2020-5-24 18:30
我刚上传了一个原附件，又下载到桌面，能解压。你再下载试试看。

谢谢老师！可以啦！

cui26896

YZC51 发表于 2020-5-24 22:29
谢谢老师！可以啦！

不客气，老师的帖是我非常关注的高水平发帖人之一，能够做一点对老师有用的事，非常乐意。

YZC51

cui26896 发表于 2020-5-24 22:48
不客气，老师的帖是我非常关注的高水平发帖人之一，能够做一点对老师有用的事，非常乐意。

老师客气啦！向您学习，共同提高！

excelvlookup

试试这个。多试几次再用，用药是大事

q563262982

excelvlookup 发表于 2020-5-25 11:56
试试这个。多试几次再用，用药是大事

老师，您的答案完全正确！
是我的原因，写错条件，需要更正上次连续间隔改为最大连续间隔/天，太失误了！

cui26896

看来老师们有事较忙，我来把更正解释的补上
Sub test2()
Dim arr, brr, crr, arr2, brr2, crr2, i&, j&, i2&, i3&, j2&, k, kk, s, p, p2, n, judge As Boolean, maxt, d As Object
Set d = CreateObject("Scripting.Dictionary")
arr = Sheets("用药收集表").Range("a2:e" & Cells(Rows.Count, 1).End(xlUp).Row)
ReDim brr(1 To UBound(arr) / 3, 1 To 5)
For i = 1 To UBound(arr)
  If Not d.exists(arr(i, 1)) Then
    k = k + 1
    d(arr(i, 1)) = k
    brr(d(arr(i, 1)), 1) = arr(i, 1)
    brr(d(arr(i, 1)), 2) = 1
    brr(d(arr(i, 1)), 3) = i
    Else
      If brr(d(arr(i, 1)), 2) + 2 = UBound(brr, 2) Then
        ReDim Preserve brr(1 To UBound(arr) / 3, 1 To brr(d(arr(i, 1)), 2) + 3)
      End If
      brr(d(arr(i, 1)), 2) = brr(d(arr(i, 1)), 2) + 1
      brr(d(arr(i, 1)), 4 + brr(d(arr(i, 1)), 2) - 2) = i
      If brr(d(arr(i, 1)), 2) > brr(k - 1, 2) Then maxt = brr(d(arr(i, 1)), 2)
  End If
Next
brr2 = Range("j2:j" & [a2].End(xlDown).Row).Value
ReDim crr(1 To k, 1 To UBound(brr, 2) + maxt)
For i = 1 To UBound(brr2)
  s = brr2(i, 1)
  If d.exists(s) Then
    kk = kk + 1
    crr(kk, 1) = brr(d(s), 1)
    crr(kk, 4) = UBound(arr) - brr(d(s), brr(d(s), 2) + 2)
    ReDim arr2(1 To brr(d(s), 2) - 1)
    ReDim crr2(1 To 4)
    For j = brr(d(s), 2) + 2 To 4 Step -1
      arr2(brr(d(s), 2) + 2 - j + 1) = brr(d(s), j) - brr(d(s), j - 1) - 1
      If Len(crr(kk, 2)) = 0 Then
        crr(kk, 2) = arr2(brr(d(s), 2) + 2 - j + 1)
      ElseIf Len(crr(kk, 2)) And arr2(brr(d(s), 2) + 2 - j + 1) > crr(kk, 2) Then
          crr(kk, 2) = arr2(brr(d(s), 2) + 2 - j + 1)
      End If
      If arr2(brr(d(s), 2) + 2 - j + 1) = 0 Then
        crr(kk, brr(d(s), 2) + 2 - j + 10) = 1
        Else
          crr(kk, brr(d(s), 2) + 2 - j + 10) = 2
      End If
    Next
    If crr(kk, 4) > crr(kk, 2) Then crr(kk, 2) = crr(kk, 4)
    crr(kk, 3) = arr2(1)
    judge = False
    For j2 = 1 To UBound(arr2)
      If arr2(j2) = 0 And judge = False Then
        crr2(1) = crr2(1) + 1
        If arr2(j2 + 1) > 0 Then judge = True
      ElseIf arr2(j2) > 0 And judge = False Then
        crr2(2) = crr2(2) + 1
      ElseIf arr2(j2) = 0 And judge = True Then
        crr2(3) = crr2(3) + 1
      ElseIf arr2(j2) > 0 And judge = True Then
        crr2(4) = crr2(4) + 1
      End If
    Next
    If crr2(1) > 0 And crr2(1) >= crr2(3) Then
      crr(kk, 5) = crr2(1) + 1
    ElseIf crr2(1) > 0 And crr2(1) < crr2(3) Then
      crr(kk, 5) = crr2(3) + 1
      Else
        crr(kk, 5) = 0
    End If
    If crr2(2) > 0 And crr2(1) > 0 Then
      crr(kk, 7) = crr2(2)
      Else
        crr(kk, 7) = 0
    End If
    If crr2(1) > 0 And (crr2(4) > 1 And crr2(3) > 0) Then
      crr(kk, 6) = crr2(4) - 1
    ElseIf crr2(1) > 0 And (crr2(4) = 1 Or crr2(3) = Empty) Then
      crr(kk, 6) = crr2(4)
      Else
        crr(kk, 6) = 0
    End If
  End If
Next
Sheets("用药收集表").Range("j2").Resize(kk, 7) = crr
End Sub