求数据间隔及连续

excelvlookup

这个贴子有点时间了，很多要慢慢理一下，问：A列有的药B列也一定有吗？B列有的药C列也一定有吗？也就是说：A、B、C列的药全等只是顺序不一致？

q563262982

excelvlookup 发表于 2020-6-6 18:48
这个贴子有点时间了，很多要慢慢理一下，问：A列有的药B列也一定有吗？B列有的药C列也一定有吗？也就是说： ...

不一定会有。
A列有的 BC列不一定会有。
B 列有的C列也不一定会有。

excelvlookup

附件中为什么洛索洛芬的“最大连续服用/天”（第4个计算值）是2，这个没清楚。在答案不完全正确前，不能给你代码！

一把小刀闯天下

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

cui26896

与楼主所要求的绝大部分都一致了，按楼主给出示例，只有图示有颜色部分有出入，不知老师和楼主哪个的对。

q563262982

一把小刀闯天下 发表于 2020-6-7 07:49
'38楼附件，分6个小问题来处理，修改起来也方便

'[s3]应该为3。另T列有3处不同，你这规则不唯一，按我 ...

经过测试，这个代码可以灵活变换运用！太厉害了太感谢了老师，

q563262982

一把小刀闯天下 发表于 2020-6-7 07:49
'38楼附件，分6个小问题来处理，修改起来也方便

'[s3]应该为3。另T列有3处不同，你这规则不唯一，按我 ...

老师，这在模块运行，指定表后会报错，是我哪里没弄对吗？在原表里面运行正常！

一把小刀闯天下

q563262982 发表于 2020-6-7 21:34
老师，这在模块运行，指定表后会报错，是我哪里没弄对吗？在原表里面运行正常！

在set dic=...  下面插入一行再试试

---------

sheets("用药收集表").select

-----------------------------------

如果再有问题可上附件，其实T列的规则到底是怎么样的倒是挺好奇的，，，

一把小刀闯天下

q563262982 发表于 2020-6-7 21:34
老师，这在模块运行，指定表后会报错，是我哪里没弄对吗？在原表里面运行正常！

对应行修改成3行更好点：

--------------------

  With Sheets("用药收集表")
    brr = .Range("a2:c" & .Cells(Rows.Count, "a").End(xlUp).Row + 1).Value
  End With

q563262982

一把小刀闯天下 发表于 2020-6-7 21:49
对应行修改成3行更好点：

--------------------

再次谢谢老师，T列的答案规则，经过核对，您的答案才是正确的！