求数据间隔及连续

cui26896 · 发表于 2020-5-25 16:21

请参考附件

q563262982 · 发表于 2020-5-25 17:21

cui26896 发表于 2020-5-25 16:21
请参考附件

之前写错了，能否将最大连续间隔次数加上，附件1楼或29楼，感谢！

excelvlookup · 发表于 2020-5-25 18:39

先找到这句：“If a4 = 0 Then b4 = UBound(ar) - j: a4 = j ”，不用改
再找到这句：“If a1 > 1 And a6 = 0 Then a6 = j”，不用改
把两句之间的代码改成这样：
If a1 = 2 Then a5 = 0
If a1 = 1 And ar(j - 1, 1) <> ar(j, 1) Then
a5 = a5 + 1: If a5 > b5 Then b5 = a5
End If
说明：第一个if表示有连续则计数归零，第二个if 一个且不连续计数加1，并和最后结果比取较大值。
数据太少没有严格测试，希望你多测试下再用，别因代码影向你的职业判断。

excelvlookup · 发表于 2020-5-25 18:42

第五个间隔出了问题，只须改与a5、b5相关的代码

cui26896 · 发表于 2020-5-25 19:16

Sub test()
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(3) > 0 Then
      If crr2(1) < crr2(3) Then
      crr(kk, 5) = crr2(3) + 1
      ElseIf crr2(1) >= crr2(3) Then
         crr(kk, 5) = crr2(1) + 1
      End If
      crr(kk, 6) = crr2(4) - 1
      If crr2(2) > 0 Then
      crr(kk, 7) = crr2(2)
      Else
         crr(kk, 7) = 0
      End If
   ElseIf crr2(1) > 0 And crr2(3) = Empty Then
      crr(kk, 5) = crr2(1) + 1
      crr(kk, 6) = crr2(4)
      If crr2(2) > 0 Then
      crr(kk, 7) = crr2(2)
      Else
         crr(kk, 7) = 0
      End If
   ElseIf crr2(1) = Empty And crr2(3) = Empty Then
      crr(kk, 5) = 0
      crr(kk, 6) = crr2(2) + 1
      crr(kk, 7) = 0
   End If
  End If
Next
Sheets("用药收集表").Range("j2").Resize(kk, 7) = crr
End Sub

cui26896 · 发表于 2020-5-25 19:17

请参考附件

求数据间隔及连续（cui终稿).zip (19.58 KB, 下载次数: 6)

q563262982 · 发表于 2020-5-25 21:00

excelvlookup 发表于 2020-5-25 18:42
第五个间隔出了问题，只须改与a5、b5相关的代码

好的，谢谢老师，稍后我在总数据库测试几次，如有问题，我在联系您！

cui26896 · 发表于 2020-5-26 18:50

做了修改，简化
Sub test2()
Dim arr, brr, crr, arr2, brr2, i&, j&, i2&, k, k2, s, s2, 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)
ReDim brr2(1 To UBound(arr) / 3, 1 To 8)
For i = 1 To UBound(arr)
  s = arr(i, 1)
  If Not d.exists(s) Then
k = k + 1
d(s) = k
brr(d(s), 1) = s
brr(d(s), 2) = 1
brr(d(s), 3) = i
If brr2(d(s), 1) = Empty And brr2(d(s), 2) = Empty Then
   If s = arr(i + 1, 1) Then
      brr2(d(s), 1) = 1: brr2(d(s), 7) = False
      Else
      brr2(d(s), 1) = 0: brr2(d(s), 2) = 1: brr2(d(s), 8) = 0
   End If
End If
Else
   If brr(d(s), 2) + 2 = UBound(brr, 2) Then
      ReDim Preserve brr(1 To UBound(arr) / 3, 1 To brr(d(s), 2) + 3)
   End If
   brr(d(s), 2) = brr(d(s), 2) + 1
   brr(d(s), 4 + brr(d(s), 2) - 2) = i
      If brr2(d(s), 5) = Empty Then
      brr2(d(s), 5) = brr(d(s), 4 + brr(d(s), 2) - 2) - brr(d(s), 3) - 1
      ElseIf brr2(d(s), 5) > 0 Then
      If (brr(d(s), 4 + brr(d(s), 2) - 2) - brr(d(s), 4 + brr(d(s), 2) - 3) - 1) > brr2(d(s), 5) Then
         brr2(d(s), 5) = brr(d(s), 4 + brr(d(s), 2) - 2) - brr(d(s), 4 + brr(d(s), 2) - 3) - 1
      End If
      End If
      If i < UBound(arr) Then
         If (s <> arr(i + 1, 1) And s = arr(i - 1, 1)) And brr2(d(s), 7) = False Then
            brr2(d(s), 1) = brr2(d(s), 1) + 1
            brr2(d(s), 7) = True
         ElseIf (s <> arr(i + 1, 1) And s = arr(i - 1, 1)) And brr2(d(s), 7) = True Then
            brr2(d(s), 3) = brr2(d(s), 3) + 1
         End If
            If s = arr(i + 1, 1) And brr2(d(s), 7) = False Then
            brr2(d(s), 1) = brr2(d(s), 1) + 1
            ElseIf s <> arr(i + 1, 1) And brr2(d(s), 7) = False Then
            brr2(d(s), 2) = brr2(d(s), 2) + 1
            ElseIf s = arr(i + 1, 1) And brr2(d(s), 7) = True Then
            brr2(d(s), 3) = brr2(d(s), 3) + 1
            ElseIf (s <> arr(i + 1, 1) And brr2(d(s), 7) = True) And s <> arr(i - 1, 1) Then
            brr2(d(s), 4) = brr2(d(s), 4) + 1: brr2(d(s), 8) = 0
            ElseIf (s <> arr(i - 1, 1) And brr2(d(s), 7) = True) And brr2(d(s), 3) > 0 Then
            brr2(d(s), 8) = brr2(d(s), 8) + 1
            End If
         Else
            s2 = brr(d(s), UBound(brr, 2) - 1) - brr(d(s), UBound(brr, 2) - 2)
            If s2 <= 1 And (s <> arr(i - 1, 1) And brr2(d(s), 7) = True) Then
            brr2(d(s), 8) = brr2(d(s), 8) + 1
            End If
      End If
  End If
Next
arr2 = Range("j2:j" & [j1].End(xlDown).Row).Value
ReDim crr(1 To UBound(arr2), 1 To 6)
For i = 1 To UBound(arr2)
  If d.exists(arr2(i, 1)) Then
k2 = k2 + 1
crr(k2, 1) = brr2(d(arr2(i, 1)), 5)
crr(k2, 2) = brr(d(arr2(i, 1)), brr(d(arr2(i, 1)), 2) + 2) - brr(d(arr2(i, 1)), brr(d(arr2(i, 1)), 2) + 1) - 1
crr(k2, 3) = UBound(arr) - brr(d(arr2(i, 1)), brr(d(arr2(i, 1)), 2) + 2)
If brr2(d(arr2(i, 1)), 3) > 0 Then
   If brr2(d(arr2(i, 1)), 3) > brr2(d(arr2(i, 1)), 1) Then
      crr(k2, 4) = brr2(d(arr2(i, 1)), 3)
      Else
      crr(k2, 4) = brr2(d(arr2(i, 1)), 1)
      crr(k2, 5) = brr2(d(arr2(i, 1)), 4)
   End If
   Else
      crr(k2, 4) = brr2(d(arr2(i, 1)), 1)
      crr(k2, 5) = brr2(d(arr2(i, 1)), 2)
End If
crr(k2, 6) = brr2(d(arr2(i, 1)), 8)
If crr(k2, 3) > crr(k2, 1) Then crr(k2, 1) = crr(k2, 3)
  End If
Next
Sheets("用药收集表").Range("k2").Resize(k2, 6) = crr
End Sub

q563262982 · 发表于 2020-6-5 20:04

excelvlookup 发表于 2020-5-25 18:39
先找到这句：“If a4 = 0 Then b4 = UBound(ar) - j: a4 = j ”，不用改
再找到这句：“If a1 > 1 And a6 ...

老师，您好！现在我有遇到问题了，有ABC这3列同时求出连续及间隔，如知道如何循环，我在附件模拟了答案，请老师帮我加一下怎么循环。

q563262982 · 发表于 2020-6-6 15:03

excelvlookup 发表于 2020-5-25 18:42
第五个间隔出了问题，只须改与a5、b5相关的代码

老师，如果三列一起是加判断还是多次循环

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

[求助] 求数据间隔及连续

评分

评分

评分

评分