Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 2804|回复: 8

查询重复间隔次数

[复制链接]
发表于 2020-5-22 17:17 | 显示全部楼层 |阅读模式
3学分
本帖最后由 q563262982 于 2020-6-10 23:29 编辑

详见附件,感谢!

excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
 楼主| 发表于 2020-5-23 17:04 | 显示全部楼层
帖子都发了一天了怎么也没有老师来帮忙解决一下啊!
回复

使用道具 举报

发表于 2020-5-23 19:36 | 显示全部楼层
q563262982 发表于 2020-5-23 17:04
帖子都发了一天了怎么也没有老师来帮忙解决一下啊!

到处伸手,不如自己动手实际做做!
回复

使用道具 举报

发表于 2020-5-24 22:03 | 显示全部楼层
附件是一个空文档。
回复

使用道具 举报

发表于 2020-5-24 22:32 | 显示全部楼层
大灰狼1976 发表于 2020-5-24 22:03
附件是一个空文档。

版主如果感兴趣,我有此附件,可以上传上来。
回复

使用道具 举报

 楼主| 发表于 2020-5-25 11:16 | 显示全部楼层
本帖最后由 q563262982 于 2020-5-25 13:36 编辑
大灰狼1976 发表于 2020-5-24 22:03
附件是一个空文档。

发了好几天了,没有一个老师解答回应!
如果版主有兴趣做解答,我在上传个附件

求解答.zip

16.66 KB, 下载次数: 3

回复

使用道具 举报

发表于 2020-5-25 16:26 | 显示全部楼层
  1. Sub test2()
  2. 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
  3. Set d = CreateObject("Scripting.Dictionary")
  4. arr = Sheets("用药收集表").Range("a2:e" & Cells(Rows.Count, 1).End(xlUp).Row)
  5. ReDim brr(1 To UBound(arr) / 3, 1 To 5)
  6. For i = 1 To UBound(arr)
  7.   If Not d.exists(arr(i, 1)) Then
  8.     k = k + 1
  9.     d(arr(i, 1)) = k
  10.     brr(d(arr(i, 1)), 1) = arr(i, 1)
  11.     brr(d(arr(i, 1)), 2) = 1
  12.     brr(d(arr(i, 1)), 3) = i
  13.     Else
  14.       If brr(d(arr(i, 1)), 2) + 2 = UBound(brr, 2) Then
  15.         ReDim Preserve brr(1 To UBound(arr) / 3, 1 To brr(d(arr(i, 1)), 2) + 3)
  16.       End If
  17.       brr(d(arr(i, 1)), 2) = brr(d(arr(i, 1)), 2) + 1
  18.       brr(d(arr(i, 1)), 4 + brr(d(arr(i, 1)), 2) - 2) = i
  19.       If brr(d(arr(i, 1)), 2) > brr(k - 1, 2) Then maxt = brr(d(arr(i, 1)), 2)
  20.   End If
  21. Next
  22. brr2 = Range("j2:j" & [a2].End(xlDown).Row).Value
  23. ReDim crr(1 To k, 1 To UBound(brr, 2) + maxt)
  24. For i = 1 To UBound(brr2)
  25.   s = brr2(i, 1)
  26.   If d.exists(s) Then
  27.     kk = kk + 1
  28.     crr(kk, 1) = brr(d(s), 1)
  29.     crr(kk, 4) = UBound(arr) - brr(d(s), brr(d(s), 2) + 2)
  30.     ReDim arr2(1 To brr(d(s), 2) - 1)
  31.     ReDim crr2(1 To 4)
  32.     For j = brr(d(s), 2) + 2 To 4 Step -1
  33.       arr2(brr(d(s), 2) + 2 - j + 1) = brr(d(s), j) - brr(d(s), j - 1) - 1
  34.       If Len(crr(kk, 2)) = 0 Then
  35.         crr(kk, 2) = arr2(brr(d(s), 2) + 2 - j + 1)
  36.       ElseIf Len(crr(kk, 2)) And arr2(brr(d(s), 2) + 2 - j + 1) > crr(kk, 2) Then
  37.           crr(kk, 2) = arr2(brr(d(s), 2) + 2 - j + 1)
  38.       End If
  39.       If arr2(brr(d(s), 2) + 2 - j + 1) = 0 Then
  40.         crr(kk, brr(d(s), 2) + 2 - j + 10) = 1
  41.         Else
  42.           crr(kk, brr(d(s), 2) + 2 - j + 10) = 2
  43.       End If
  44.     Next
  45.     If crr(kk, 4) > crr(kk, 2) Then crr(kk, 2) = crr(kk, 4)
  46.     crr(kk, 3) = arr2(1)
  47.     judge = False
  48.     For j2 = 1 To UBound(arr2)
  49.       If arr2(j2) = 0 And judge = False Then
  50.         crr2(1) = crr2(1) + 1
  51.         If arr2(j2 + 1) > 0 Then judge = True
  52.       ElseIf arr2(j2) > 0 And judge = False Then
  53.         crr2(2) = crr2(2) + 1
  54.       ElseIf arr2(j2) = 0 And judge = True Then
  55.         crr2(3) = crr2(3) + 1
  56.       ElseIf arr2(j2) > 0 And judge = True Then
  57.         crr2(4) = crr2(4) + 1
  58.       End If
  59.     Next
  60.     If crr2(1) > 0 And crr2(1) >= crr2(3) Then
  61.       crr(kk, 5) = crr2(1) + 1
  62.     ElseIf crr2(1) > 0 And crr2(1) < crr2(3) Then
  63.       crr(kk, 5) = crr2(3) + 1
  64.       Else
  65.         crr(kk, 5) = 0
  66.     End If
  67.     If crr2(2) > 0 And crr2(1) > 0 Then
  68.       crr(kk, 7) = crr2(2)
  69.       Else
  70.         crr(kk, 7) = 0
  71.     End If
  72.     If crr2(1) > 0 And (crr2(4) > 1 And crr2(3) > 0) Then
  73.       crr(kk, 6) = crr2(4) - 1
  74.     ElseIf crr2(1) > 0 And (crr2(4) = 1 Or crr2(3) = Empty) Then
  75.       crr(kk, 6) = crr2(4)
  76.       Else
  77.         crr(kk, 6) = 0
  78.     End If
  79.   End If
  80. Next
  81. Sheets("用药收集表").Range("j2").Resize(kk, 7) = crr
  82. End Sub
复制代码
求数据间隔及连续(cui).zip (22.69 KB, 下载次数: 0)

评分

参与人数 2学分 +13 收起 理由
q563262982 + 3 我和小伙伴都惊呆了
大灰狼1976 + 10 这么长,辛苦了!

查看全部评分

回复

使用道具 举报

发表于 2020-5-26 11:15 | 显示全部楼层
感谢版主的鼓励!水平较低,做了一些改进,但是还是不满意!
回复

使用道具 举报

发表于 2020-5-26 18:48 | 显示全部楼层
再次做了修改,减化
  1. Sub test2()
  2. Dim arr, brr, crr, arr2, brr2, i&, j&, i2&, k, k2, s, s2, d As Object
  3. Set d = CreateObject("Scripting.Dictionary")
  4. arr = Sheets("用药收集表").Range("a2:e" & Cells(Rows.Count, 1).End(xlUp).Row)
  5. ReDim brr(1 To UBound(arr) / 3, 1 To 5)
  6. ReDim brr2(1 To UBound(arr) / 3, 1 To 8)
  7. For i = 1 To UBound(arr)
  8.   s = arr(i, 1)
  9.   If Not d.exists(s) Then
  10.     k = k + 1
  11.     d(s) = k
  12.     brr(d(s), 1) = s
  13.     brr(d(s), 2) = 1
  14.     brr(d(s), 3) = i
  15.     If brr2(d(s), 1) = Empty And brr2(d(s), 2) = Empty Then
  16.       If s = arr(i + 1, 1) Then
  17.         brr2(d(s), 1) = 1: brr2(d(s), 7) = False
  18.         Else
  19.           brr2(d(s), 1) = 0: brr2(d(s), 2) = 1: brr2(d(s), 8) = 0
  20.       End If
  21.     End If
  22.     Else
  23.       If brr(d(s), 2) + 2 = UBound(brr, 2) Then
  24.         ReDim Preserve brr(1 To UBound(arr) / 3, 1 To brr(d(s), 2) + 3)
  25.       End If
  26.       brr(d(s), 2) = brr(d(s), 2) + 1
  27.       brr(d(s), 4 + brr(d(s), 2) - 2) = i
  28.         If brr2(d(s), 5) = Empty Then
  29.           brr2(d(s), 5) = brr(d(s), 4 + brr(d(s), 2) - 2) - brr(d(s), 3) - 1
  30.         ElseIf brr2(d(s), 5) > 0 Then
  31.           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
  32.             brr2(d(s), 5) = brr(d(s), 4 + brr(d(s), 2) - 2) - brr(d(s), 4 + brr(d(s), 2) - 3) - 1
  33.           End If
  34.         End If
  35.           If i < UBound(arr) Then
  36.             If (s <> arr(i + 1, 1) And s = arr(i - 1, 1)) And brr2(d(s), 7) = False Then
  37.               brr2(d(s), 1) = brr2(d(s), 1) + 1
  38.               brr2(d(s), 7) = True
  39.             ElseIf (s <> arr(i + 1, 1) And s = arr(i - 1, 1)) And brr2(d(s), 7) = True Then
  40.               brr2(d(s), 3) = brr2(d(s), 3) + 1
  41.             End If
  42.               If s = arr(i + 1, 1) And brr2(d(s), 7) = False Then
  43.                 brr2(d(s), 1) = brr2(d(s), 1) + 1
  44.               ElseIf s <> arr(i + 1, 1) And brr2(d(s), 7) = False Then
  45.                 brr2(d(s), 2) = brr2(d(s), 2) + 1
  46.               ElseIf s = arr(i + 1, 1) And brr2(d(s), 7) = True Then
  47.                 brr2(d(s), 3) = brr2(d(s), 3) + 1
  48.               ElseIf (s <> arr(i + 1, 1) And brr2(d(s), 7) = True) And s <> arr(i - 1, 1) Then
  49.                 brr2(d(s), 4) = brr2(d(s), 4) + 1: brr2(d(s), 8) = 0
  50.               ElseIf (s <> arr(i - 1, 1) And brr2(d(s), 7) = True) And brr2(d(s), 3) > 0 Then
  51.                 brr2(d(s), 8) = brr2(d(s), 8) + 1
  52.               End If
  53.             Else
  54.               s2 = brr(d(s), UBound(brr, 2) - 1) - brr(d(s), UBound(brr, 2) - 2)
  55.               If s2 <= 1 And (s <> arr(i - 1, 1) And brr2(d(s), 7) = True) Then
  56.                 brr2(d(s), 8) = brr2(d(s), 8) + 1
  57.               End If
  58.           End If
  59.   End If
  60. Next
  61. arr2 = Range("j2:j" & [j1].End(xlDown).Row).Value
  62. ReDim crr(1 To UBound(arr2), 1 To 6)
  63. For i = 1 To UBound(arr2)
  64.   If d.exists(arr2(i, 1)) Then
  65.     k2 = k2 + 1
  66.     crr(k2, 1) = brr2(d(arr2(i, 1)), 5)
  67.     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
  68.     crr(k2, 3) = UBound(arr) - brr(d(arr2(i, 1)), brr(d(arr2(i, 1)), 2) + 2)
  69.     If brr2(d(arr2(i, 1)), 3) > 0 Then
  70.       If brr2(d(arr2(i, 1)), 3) > brr2(d(arr2(i, 1)), 1) Then
  71.         crr(k2, 4) = brr2(d(arr2(i, 1)), 3)
  72.         Else
  73.           crr(k2, 4) = brr2(d(arr2(i, 1)), 1)
  74.           crr(k2, 5) = brr2(d(arr2(i, 1)), 4)
  75.       End If
  76.       Else
  77.         crr(k2, 4) = brr2(d(arr2(i, 1)), 1)
  78.         crr(k2, 5) = brr2(d(arr2(i, 1)), 2)
  79.     End If
  80.     crr(k2, 6) = brr2(d(arr2(i, 1)), 8)
  81.     If crr(k2, 3) > crr(k2, 1) Then crr(k2, 1) = crr(k2, 3)
  82.   End If
  83. Next
  84. Sheets("用药收集表").Range("k2").Resize(k2, 6) = crr
  85. End Sub
复制代码

评分

参与人数 1学分 +3 收起 理由
q563262982 + 3 我和小伙伴都惊呆了

查看全部评分

回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-29 08:50 , Processed in 0.301696 second(s), 15 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表