求数据间隔及连续

q563262982

求查询数据的间隔以及连续次数VBA，详见附件！
目前还没有得到正确答案，如果对第一次发的附件不是很明白，可以下载第二版附件参考！


补充内容 (2020-6-7 13:16):
目前已经得到正确答案，在置顶3楼！
感谢本帖参与编写代码的老师们，最诚挚的的感谢及祝福都送给你们。
特别感谢”小刀“老师的完美代码


补充内容 (2020-6-12 00:26):
最后感谢“excelvlookup”老师，60楼终结本帖的问题，再次感谢参与的老师们,辛苦了！

一把小刀闯天下

'示例结果太少，以凑为主，，，

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

'"最大连续服用天数"计算有问题，感谢cui26896老师的提醒,其实其它地方可能还有问题。他这文字说明看不太懂，最主要的是示例结果数据太少，有几个地方是猜着写的。


Option Explicit

Sub test()
  Dim arr, brr, i, j, k, kk, n, dic, flag(1) As Boolean
  Set dic = CreateObject("scripting.dictionary")
  arr = [a1].CurrentRegion.Offset(1).Resize(, 6).Value
  For i = 1 To UBound(arr, 1) - 1
    If Not dic.exists(arr(i, 1)) Then j = j + 1: dic(arr(i, 1)) = j
    arr(i, 6) = dic(arr(i, 1))
  Next
  brr = Range("j2:j" & [j2].End(xlDown).Row).Value
  ReDim crr(1 To UBound(brr, 1), 1 To 6), drr(UBound(crr, 2)) As Long
  For i = 1 To UBound(brr, 1)
    If dic.exists(brr(i, 1)) Then
      n = dic(brr(i, 1)): flag(0) = False: flag(1) = False
      For j = UBound(arr, 1) - 1 To 1 Step -1
        If arr(j, 6) = n Then
          If flag(1) = False Then flag(1) = True: drr(3) = UBound(arr, 1) - j - 1
          For k = j - 1 To 1 Step -1
            If arr(k, 6) = n Then
              If flag(0) = False Then flag(0) = True: drr(2) = j - k - 1
              If j - k - 1 > drr(1) Then drr(1) = j - k - 1
              For kk = j To 1 Step -1
                If arr(kk, 6) <> n Then
                  If drr(4) < j - kk And j - kk > 1 Then drr(4) = j - kk
                  Exit For
                End If
              Next
              If kk = 0 Then
                If drr(4) < j And j > 1 Then drr(4) = j
              End If
              j = k + 1: Exit For
            End If
          Next
        End If
      Next
      If drr(4) > 0 Then
        For j = 1 To UBound(arr, 1) - 1
          If arr(j, 6) = n And arr(j + 1, 6) = n Then
            For k = j + 2 To UBound(arr, 1) - 1
              If arr(k, 6) <> n Then
                For kk = k + 1 To UBound(arr, 1) - 1
                  If arr(kk, 6) = n Then drr(5) = 1: k = UBound(arr, 1): j = k: Exit For
                Next
              End If
            Next
          End If
        Next
        If arr(UBound(arr) - 1, 6) = n And arr(UBound(arr) - 2, 6) = n Then drr(6) = 1
      End If
      For j = 1 To UBound(crr, 2)
        crr(i, j) = drr(j): drr(j) = 0
      Next
    End If
  Next
  [k2].Resize(UBound(crr, 1), UBound(crr, 2)) = crr
End Sub

一把小刀闯天下

q563262982 发表于 2020-5-24 20:48
小刀老师，非常感谢您的代码，但我发现有错误，主要出现在(最大间隔，上次连续间隔，当前连续间隔）,由于 ...

'38楼附件，分6个小问题来处理，修改起来也方便

'[s3]应该为3。另T列有3处不同，你这规则不唯一，按我的理解分3种规则来处理的

'[a:c]列为源数据，其实列数可以不限的，自己修改，，，

Option Explicit

Sub test()
  Dim arr, brr, i, j, k, dic, cnt
  Set dic = CreateObject("scripting.dictionary")
  brr = Range("a2:c" & Cells(Rows.Count, "a").End(xlUp).Row + 1).Value
  ReDim arr(UBound(brr, 1), 1 To UBound(brr, 1))
  For j = 1 To UBound(brr, 2)
    For i = 1 To UBound(brr, 1) - 1
      If Not dic.exists(brr(i, j)) Then
        cnt = cnt + 1: dic(brr(i, j)) = cnt
        arr(0, cnt) = brr(i, j): arr(i, cnt) = brr(i, j)
      End If
      For k = 1 To UBound(brr, 2)
        If brr(i, k) = arr(0, dic(brr(i, j))) Then
          arr(i, dic(brr(i, j))) = brr(i, k)
          Exit For
        End If
      Next
    Next
  Next
  ReDim brr(1 To cnt, 1 To 1 + 6)
  For j = 1 To cnt
    brr(j, 1) = arr(0, j)
    Call qu1(arr, brr, j) '最大间隔/天
    Call qu2(arr, brr, j) '上次服用间隔/天
    Call qu3(arr, brr, j) '当前间隔/天
    Call qu4(arr, brr, j) '最大连续服用/天
    Call qu5(arr, brr, j) '上次连续服用间隔/次
    Call qu6(arr, brr, j) '当前连续服用间隔/次
  Next
  [o13].Resize(UBound(brr, 1), UBound(brr, 2)) = brr '对比用，自己修改输出位置
End Sub

Sub qu1(arr, brr, col)
  Dim i, j, p, n
  p = 1
  For i = 1 To UBound(arr, 1) - 1
    If Len(arr(i, col)) > 0 Or i = UBound(arr, 1) - 1 Then
      If i = UBound(arr, 1) - 1 And Len(arr(i, col)) = 0 Then
        If i - p + 1 > n And i - p + 1 > 1 Then n = i - p + 1
      Else
        If i - p > n And i - p > 1 Then n = i - p
        For j = i + 1 To UBound(arr, 1) - 1
          If Len(arr(j, col)) = 0 Then p = j: i = j: Exit For
        Next
      End If
    End If
  Next
  brr(col, 2) = n
End Sub

Function qu2(arr, brr, col)
  Dim i, j
  For i = UBound(arr, 1) - 1 To 1 Step -1
    If Len(arr(i, col)) Then
      For j = i - 1 To 1 Step -1
        If Len(arr(j, col)) Then
          If i - j > 1 Then brr(col, 3) = i - j - 1
          i = 1: Exit For
        End If
      Next
    End If
  Next
  If Len(brr(col, 3)) = 0 Then brr(col, 3) = 0
End Function

Function qu3(arr, brr, col)
  Dim i
  For i = UBound(arr, 1) - 1 To 1 Step -1
    If Len(arr(i, col)) Then brr(col, 4) = UBound(arr, 1) - i - 1: Exit For
  Next
End Function

Function qu4(arr, brr, col)
  Dim i, j, n
  For i = 1 To UBound(arr, 1)
    If Len(arr(i, col)) Then
      For j = i + 1 To UBound(arr, 1) - 1
        If Len(arr(j, col)) = 0 Then
          If j - i > 1 And j - i > n Then n = j - i
          i = j: Exit For
        End If
      Next
    End If
  Next
  If n > 0 Then brr(col, 5) = n Else brr(col, 5) = 0
End Function

Function qu5(arr, brr, col)
  Dim i, j, k, n
  For i = UBound(arr, 1) - 1 To 2 Step -1
    If Len(arr(i, col)) Then n = n + 1
    If Len(arr(i, col)) > 0 And Len(arr(i - 1, col)) Then
      n = 0
      For j = i - 1 To 1 Step -1
        If Len(arr(j + 1, col)) = 0 And Len(arr(j, col)) > 0 Then n = n + 1
        If Len(arr(j, col)) = 0 Then
          n = 0
          For k = j - 1 To 2 Step -1
            If Len(arr(k, col)) > 0 And Len(arr(k - 1, col)) > 0 Then: j = 0: i = 0: Exit For
            If Len(arr(k, col)) Then n = n + 1
          Next
          If k = 1 Then
            If Len(arr(k, col)) Then n = n + 1
            i = 0: Exit For
          End If
        End If
      Next
    End If
  Next
  If i = 1 And Len(arr(1, col)) > 0 Then n = n + 1
  brr(col, 6) = n
End Function

Function qu6(arr, brr, col)
  Dim i, j, n
  For i = UBound(arr, 1) - 1 To 2 Step -1
    If Len(arr(i, col)) > 0 And Len(arr(i - 1, col)) > 0 Then Exit For
    If Len(arr(i, col)) Then n = n + 1
  Next
  If i = 1 Then n = 0
  If n > 0 Then brr(col, 7) = n Else brr(col, 7) = 0
End Function

q563262982

在线刷抖音等待各位老师回复！

excelvlookup

有几个问题要明确一下：
1、最大间隔/天，如果只有一次，应为：第二行到服用日，与服用日到当前日的较大值？
2、上次服用间隔/天，按你的表述为：最后一个1，到最后一个1的上面一个1的天数，只有一次的如何计算？
3、最大连续服用/天，如果没有连续服用的是1 还是0，按示例两天服用是2，一天服用为0，几天服用为1呢？
4、上次连续服用间隔/次，如果只有一次连续服用如何计算？没有连续服用的又如何计算？
5、当前连续服用间隔/次，按文字表述为最后一次连续后，隔几期再连续。问：既然有再连续，就不是最后一次连续，所以永远为0
请认真一个一个地回答。

cui26896

提出的要求中示例中就有错误，好一个猜呀！甲氨蝶呤，当前间隔/天 楼主给出的是4天，是按距离最后一行有多少行来算的，5月4日距离5月7日间隔天数只有两天啊！给了个4天，好得一个猜啊！
样例.zip (16.94 KB, 下载次数: 6)

2020-5-23 14:58 上传

点击文件名下载附件

cui26896

Option Explicit
Sub test()
Dim arr, brr, crr, crr2, i&, j&, k, 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) = arr(i, 5)
    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) = arr(i, 5)
      If brr(d(arr(i, 1)), 2) > brr(k - 1, 2) Then maxt = brr(d(arr(i, 1)), 2)
  End If
Next
ReDim crr(1 To k, 1 To 12)
For i = 1 To UBound(crr)
  crr(i, 1) = brr(i, 1)
  crr(i, 9) = 1
  If brr(i, 2) = 1 Then
    crr(i, 2) = 1: crr(i, 3) = 0: crr(i, 4) = arr(UBound(arr), 5) - brr(i, 3): crr(i, 5) = 0: crr(i, 6) = 0: crr(i, 7) = 0
    Else
      For j = 3 To brr(i, 2) + 2
        If j = brr(i, 2) + 2 Then
          If brr(i, j) = brr(i, j - 1) Then
            crr(i, 3) = brr(i, j) - brr(i, j - 1)
            Else
              crr(i, 3) = brr(i, j) - brr(i, j - 1) - 1
          End If
            If brr(i, j) = arr(UBound(arr), 5) Or brr(i, j) = brr(i, j - 1) Then
              crr(i, 4) = arr(UBound(arr), 5) - brr(i, j)
              Else
                crr(i, 4) = arr(UBound(arr), 5) - brr(i, j) - 1
            End If
              If brr(i, j - 1) = crr(i, 10) Then
                crr(i, 6) = crr(i, 5)
                Else
                  crr(i, 6) = 1
              End If
                If brr(i, j) <> arr(UBound(arr), 5) Then
                  crr(i, 7) = 0
                ElseIf brr(i, j) = arr(UBound(arr), 5) And brr(i, j) <> crr(i, 10) Then
                  crr(i, 7) = 1
                  Else
                    crr(i, 7) = crr(i, 5)
                End If
            End If
              If j > brr(i, 2) + 1 Then Exit For
                If (brr(i, j + 1) - brr(i, j) = 1 Or brr(i, j + 1) = brr(i, j)) And crr(i, 5) = Empty Then
                  crr(i, 11) = True
                  If crr(i, 11) And crr(i, 9) = 1 Then
                    crr(i, 12) = crr(i, 12) + 2
                    crr(i, 9) = crr(i, 9) + 1
                    crr(i, 5) = crr(i, 12)
                    crr(i, 10) = brr(i, j + 1)
                  End If
                ElseIf (brr(i, j + 1) - brr(i, j) = 1 Or brr(i, j + 1) = brr(i, j)) And j = brr(i, 2) + 1 Then
                  crr(i, 2) = brr(i, j) - brr(i, j - 1) - 1
                ElseIf brr(i, j + 1) - brr(i, j) > 1 And crr(i, 5) <> Empty Then
                  crr(i, 9) = 1: crr(i, 12) = Empty
                ElseIf (brr(i, j + 1) - brr(i, j) = 1 Or brr(i, j + 1) = brr(i, j)) And crr(i, 5) <> Empty Then
                  crr(i, 11) = True
                  If crr(i, 11) And crr(i, 9) = 1 Then
                    crr(i, 12) = crr(i, 12) + 2
                    crr(i, 5) = crr(i, 12)
                    crr(i, 10) = brr(i, j + 1)
                    crr(i, 9) = crr(i, 9) + 1
                  ElseIf crr(i, 11) And crr(i, 9) > 1 Then
                    crr(i, 12) = crr(i, 12) + 1
                    If crr(i, 12) >= crr(i, 5) Then
                      crr(i, 5) = crr(i, 12)
                      crr(i, 10) = brr(i, j + 1)
                    End If
                  End If
                ElseIf (brr(i, j + 1) - brr(i, j)) > 1 And crr(i, 2) = Empty Then
                  crr(i, 2) = brr(i, j + 1) - brr(i, j) - 1
                ElseIf (brr(i, j + 1) - brr(i, j)) > 1 And crr(i, 2) <> Empty Then
                  If (brr(i, j + 1) - brr(i, j)) > crr(i, 2) Then
                    crr(i, 2) = brr(i, j + 1) - brr(i, j) - 1
                  End If
              End If
      Next
    If crr(i, 5) = Empty Then crr(i, 5) = 0
  End If
Next
Sheets("用药收集表").Range("j2").Resize(UBound(crr), 7) = crr
End Sub

q563262982

cui26896 发表于 2020-5-23 14:59
Option Explicit
Sub test()
Dim arr, brr, crr, crr2, i&, j&, k, maxt, d As Object

这是您纯手工写的吗，“我的天啦”，太不容易了，都不直到怎么感激。
但是答案有错误，

lixiaoxue

1，楼主的问题，我之前业遇到过，其实不用去管"B","C","D","E"列,2，只需要根据  "J"   列，第2行 开始的有效值与  “A”  列第二行开始的有效值进行查询与计算即可。3，其实用函数公式添加辅助列也可以实现答案，。

4，附件中 我只有当前最大服用间隔，当前服用间隔，也就是“K”，“M”列的答案，要完整的代码，您还需要继续求助群里的老师们。

q563262982

excelvlookup 发表于 2020-5-23 12:26
有几个问题要明确一下：
1、最大间隔/天，如果只有一次，应为：第二行到服用日，与服用日到当前日的较大值 ...

关于您提的问题请参考附件表格模拟参考的 计算方式，您可能没有明白我的表述。

xiangbaoan

cui26896 发表于 2020-5-23 14:59
Option Explicit
Sub test()
Dim arr, brr, crr, crr2, i&, j&, k, maxt, d As Object

老师威武……

lixiaoxue

q563262982 发表于 2020-5-23 17:24
关于您的问题回复：
关于1，2问题：
最大间隔天，即A列中两个重复药品名称之前的 最大行间距.

根据"J"列与"A"列对应计算即可，无需把BCDE列拉进来。