[已解决]很多列中7个数字连续出现的最大次数

zss7758258

请教.zip (7.32 KB, 下载次数: 22)

2014-1-25 18:25 上传

点击文件名下载附件

春节到来之际，祝各位老师同学节日快乐！

最佳答案

月排行榜 / 总排行榜

大灰狼1976

2014-1-26 20:30

附件请测试，由于版本关系，代码内不能用中文，你测试无误后可以将"ge shu zi"替换为"个数字"

1. Sub aaa()
   
2. Dim arr, i&, j&, k&, d As Object, m&, n&, ad&, r&, brr, s$, s1$, c
   
3. s = "0123456789"
   
4. Set d = CreateObject("scripting.dictionary")
   
5. arr = Sheets(1).[a1].CurrentRegion
   
6. For j = 1 To UBound(arr, 2)
   
7.   For i = 1 To UBound(arr) - 6
   
8.     For k = i To UBound(arr)
   
9.       d(arr(k, j)) = d(arr(k, j)) + 1
   
10.       If d.Count > 7 Then d.Remove (arr(k, j)): Exit For
    
11.     Next k
    
12.     If d.Count = 7 Then
    
13.       n = Application.Sum(d.items)
    
14.       If m <= n Then
    
15.         If m = n Then
    
16.           r = r + 1
    
17.         ElseIf m < n Then
    
18.           m = n
    
19.           ReDim brr(1 To 100, 1 To 6)
    
20.           r = 1
    
21.         End If
    
22.         brr(r, 1) = Join(d.keys, "")
    
23.         brr(r, 2) = Replace(Cells(i, j).Address, "$", "")
    
24.         brr(r, 3) = Replace(Cells(k, j).Address, "$", "")
    
25.         s1 = s
    
26.         For Each c In d.keys
    
27.           s1 = Replace(s1, c, "")
    
28.         Next c
    
29.         brr(r, 4) = m
    
30.         brr(r, 5) = Len(s1)
    
31.         brr(r, 6) = s1
    
32.       End If
    
33.     End If
    
34.     d.RemoveAll
    
35.   Next i
    
36. Next j
    
37. [b2].Resize(UBound(brr)) = Application.Index(brr, , 1)
    
38. [d2].Resize(UBound(brr)) = Application.Index(brr, , 2)
    
39. [f2].Resize(UBound(brr)) = Application.Index(brr, , 3)
    
40. [h2].Resize(UBound(brr)) = Application.Index(brr, , 4)
    
41. [j2].Resize(UBound(brr)) = Application.Index(brr, , 6)
    
42. [j1] = brr(1, 5) & "ge shu zi"
    
43. End Sub

复制代码

跳转到最佳答案楼层

tgydslr

看起来好麻烦啊

zss7758258

tgydslr 发表于 2014-1-25 18:45
看起来好麻烦啊

{:021:}谢谢关注

芐雨

不明白，你想求什么？
是已知那七个数字，出现次数为31，求区域

zss7758258

芐雨 发表于 2014-1-25 21:03
不明白，你想求什么？
是已知那七个数字，出现次数为31，求区域

C4：C34中1564082这七个数字出现了31次，是已知单元格区域中出现次数最多的，通过《求结果》表中的按钮，求出结果：1564082从C4到C34出现31次，

也可以这样理解：1564082这七个数字在C4：C34中数完后，单元格C35出现了第八个数字3，这时候停止数数，从C4:C35共有32格，减去第八个数字出现的那一个一格，要求的结果为31。

zss7758258

再来看看，求解

芐雨

这么晚，早点睡吧！
举例里多余的数据先删除，如附件。你测试下吧

1. Sub 连续七个数出现的最大值_芐雨()
   
2. Dim brr(1 To 1000000, 2), crr(1 To 10000, 1 To 11)
   
3. Dim Rng As Range, arr
   
4. 
   
5. Application.ScreenUpdating = False
   
6. 
   
7. Set d = CreateObject("scripting.dictionary")
   
8. Set Rng = Sheets("举例").Range("A1").CurrentRegion '范围
   
9. 
   
10. Sheets("求结果").Range("A2").Resize(Rows.Count - 1, 11).Clear '清除数据
    
11. col = Rng(Rng.Count).Column '列数
    
12. arr = Rng
    
13. y = 1
    
14. For j = 1 To col
    
15. d.RemoveAll '每次转列:清空字典
    
16. x = x + 1
    
17. y = y + 7
    
18. jmax = 0
    
19. For i = 1 To UBound(arr)
    
20. arr(i, j) = arr(i, j) & "" '转成字符
    
21. If Not d.exists(arr(i, j)) Or i = UBound(arr) Then '字典不存在或最后一行时运行
    
22. k = k + 1 '记录字典数
    
23. d(arr(i, j)) = "" '添加字典
    
24. brr(x, 1) = brr(x, 1) & arr(i, j) '记录出现的数
    
25. If brr(x, 2) <> "" Then
    
26. brr(x, 2) = brr(x, 2) & ":" & Cells(i, j).Address '记录地址
    
27. Else
    
28. brr(x, 2) = Cells(i, j).Address '记录地址
    
29. End If
    
30. If k = y Then
    
31. If i < UBound(arr) Then '不是最后一行时
    
32. d.Remove (Left(brr(x, 1), 1)) '删除第一个数的字典
    
33. L = InStrRev(brr(x, 2), "$") '最后一个$的位置
    
34. brr(x, 2) = Left(brr(x, 2), L) & Right(brr(x, 2), Len(brr(x, 2)) - L) - 1 '最后一个地址上移一格
    
35. End If
    
36. imax = Range(brr(x, 2)).Count '求出连续出现的数
    
37. If imax > jmax Then '比较是否最大值
    
38. jmax = imax
    
39. crr(j, 2) = "'" & Left(brr(x, 1), 7) '转成文本数值，记录出现什么数
    
40. crr(j, 4) = Range(brr(x, 2)).Item(1).Address(0, 0) '返回区域内的第一个地址
    
41. crr(j, 6) = Range(brr(x, 2)).Item(imax).Address(0, 0) '返回区域内的最后个地址
    
42. crr(j, 8) = jmax '连续出现的次数
    
43. End If
    
44. x = x + 1
    
45. y = y + 1
    
46. brr(x, 1) = Right(brr(x - 1, 1), 7) '生成新的连续数
    
47. brr(x, 2) = Right(brr(x - 1, 2), Len(brr(x - 1, 2)) - InStr(1, brr(x - 1, 2), ":")) '生成新的连续数地址
    
48. End If
    
49. End If
    
50. Next
    
51. Next
    
52. 
    
53. For j = 1 To col
    
54. crr(j, 1) = "第" & j & "列最大结果"
    
55. crr(j, 3) = "从"
    
56. crr(j, 5) = "到"
    
57. crr(j, 7) = "次"
    
58. crr(j, 9) = "出现"
    
59. crr(j, 11) = "没有出现"
    
60. crr(j, 10) = "1234567890"
    
61. For i = 2 To 8 '找出没有出现的数
    
62. crr(j, 10) = Replace(crr(j, 10), Val(Mid(crr(j, 2), i, 1)), "")
    
63. Next
    
64. Next
    
65. 
    
66. Sheets("求结果").Range("A2").Resize(col, 11) = crr
    
67. Application.ScreenUpdating = True
    
68. End Sub

复制代码

连续七个数出现的最大值_芐雨.rar (12.63 KB, 下载次数: 3)

2014-1-26 13:14 上传

点击文件名下载附件

zss7758258

芐雨 发表于 2014-1-26 13:18
这么晚，早点睡吧！
举例里多余的数据先删除，如附件。你测试下吧

请教3333.zip (17.64 KB, 下载次数: 2)

2014-1-26 19:10 上传

点击文件名下载附件

结果有误，请参考本楼文件的表《举例》，谢谢您的帮助，还请继续指导

大灰狼1976

附件请测试，由于版本关系，代码内不能用中文，你测试无误后可以将"ge shu zi"替换为"个数字"

1. Sub aaa()
   
2. Dim arr, i&, j&, k&, d As Object, m&, n&, ad&, r&, brr, s$, s1$, c
   
3. s = "0123456789"
   
4. Set d = CreateObject("scripting.dictionary")
   
5. arr = Sheets(1).[a1].CurrentRegion
   
6. For j = 1 To UBound(arr, 2)
   
7.   For i = 1 To UBound(arr) - 6
   
8.     For k = i To UBound(arr)
   
9.       d(arr(k, j)) = d(arr(k, j)) + 1
   
10.       If d.Count > 7 Then d.Remove (arr(k, j)): Exit For
    
11.     Next k
    
12.     If d.Count = 7 Then
    
13.       n = Application.Sum(d.items)
    
14.       If m <= n Then
    
15.         If m = n Then
    
16.           r = r + 1
    
17.         ElseIf m < n Then
    
18.           m = n
    
19.           ReDim brr(1 To 100, 1 To 6)
    
20.           r = 1
    
21.         End If
    
22.         brr(r, 1) = Join(d.keys, "")
    
23.         brr(r, 2) = Replace(Cells(i, j).Address, "$", "")
    
24.         brr(r, 3) = Replace(Cells(k, j).Address, "$", "")
    
25.         s1 = s
    
26.         For Each c In d.keys
    
27.           s1 = Replace(s1, c, "")
    
28.         Next c
    
29.         brr(r, 4) = m
    
30.         brr(r, 5) = Len(s1)
    
31.         brr(r, 6) = s1
    
32.       End If
    
33.     End If
    
34.     d.RemoveAll
    
35.   Next i
    
36. Next j
    
37. [b2].Resize(UBound(brr)) = Application.Index(brr, , 1)
    
38. [d2].Resize(UBound(brr)) = Application.Index(brr, , 2)
    
39. [f2].Resize(UBound(brr)) = Application.Index(brr, , 3)
    
40. [h2].Resize(UBound(brr)) = Application.Index(brr, , 4)
    
41. [j2].Resize(UBound(brr)) = Application.Index(brr, , 6)
    
42. [j1] = brr(1, 5) & "ge shu zi"
    
43. End Sub

复制代码

芐雨

1. Sub 区域内连续七个数出现的最大值_芐雨()
   
2.     Dim brr(), crr()
   
3.     Dim Rng As Range, arr
   
4.     Application.ScreenUpdating = False
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     Set Rng = Sheets("举例").Range("A1").CurrentRegion    '范围
   
7.     Sheets("求结果").Range("A2").Resize(Rows.Count - 1, 11).Clear    '清除数据
   
8.     col = Rng(Rng.Count).Column    '列数
   
9.     arr = Rng
   
10.     For j = 1 To col
    
11.         ReDim brr(1 To UBound(arr), 1 To 2)
    
12.         x = 1
    
13.         For i = 1 To UBound(arr)
    
14.             arr(i, j) = arr(i, j) & ""    '转成字符
    
15.             If Not d.exists(arr(i, j)) Or i = UBound(arr) Then    '字典不存在或最后一行时运行
    
16.                 k = k + 1    '记录字典数
    
17.                 d(arr(i, j)) = ""    '添加字典
    
18.                 brr(x, 1) = brr(x, 1) & arr(i, j)    '记录出现的数
    
19.                 If brr(x, 2) <> "" Then
    
20.                     brr(x, 2) = brr(x, 2) & ":" & Cells(i, j).Address    '记录地址
    
21.                 Else
    
22.                     brr(x, 2) = Cells(i, j).Address    '记录地址
    
23.                 End If
    
24.                 If k = 8 Then
    
25.                     If i < UBound(arr) Then    '不是最后一行时
    
26.                         d.Remove (Left(brr(x, 1), 1))    '删除第一个数的字典
    
27.                         L = InStrRev(brr(x, 2), "$")    '最后一个$的位置
    
28.                         brr(x, 2) = Left(brr(x, 2), L) & Right(brr(x, 2), Len(brr(x, 2)) - L) - 1    '最后一个地址上移一格
    
29.                     End If
    
30.                     imax = Range(brr(x, 2)).Count    '求出连续出现的数
    
31.                     If imax = jmax Then    '最大值相同时
    
32.                         m = m + 1
    
33.                         crr(m, 2) = "'" & Left(brr(x, 1), 7)    '转成文本数值，记录出现什么数
    
34.                         crr(m, 4) = Range(brr(x, 2)).Item(1).Address(0, 0)    '返回区域内的第一个地址
    
35.                         crr(m, 6) = Range(brr(x, 2)).Item(imax).Address(0, 0)    '返回区域内的最后个地址
    
36.                         crr(m, 8) = jmax    '连续出现的次数
    
37.                     End If
    
38.                     If imax > jmax Then    '比较是否最大值
    
39.                         ReDim crr(1 To 1000, 1 To 11)  '有最大值清空数组
    
40.                         jmax = imax
    
41.                         m = 1
    
42.                         crr(m, 2) = "'" & Left(brr(x, 1), 7)    '转成文本数值，记录出现什么数
    
43.                         crr(m, 4) = Range(brr(x, 2)).Item(1).Address(0, 0)    '返回区域内的第一个地址
    
44.                         crr(m, 6) = Range(brr(x, 2)).Item(imax).Address(0, 0)    '返回区域内的最后个地址
    
45.                         crr(m, 8) = jmax    '连续出现的次数
    
46.                     End If
    
47.                     x = x + 1    '记录
    
48.                     d.RemoveAll
    
49.                     k = 0
    
50.                     If i = UBound(arr) Then Exit For
    
51.                     i = x
    
52.                 End If
    
53.             End If
    
54.         Next
    
55.     Next
    
56.     For j = 1 To m
    
57.         If j > 1 Then dd = "重复"
    
58.         crr(j, 1) = dd & "第" & j & "个最大结果"
    
59.         crr(j, 3) = "从"
    
60.         crr(j, 5) = "到"
    
61.         crr(j, 7) = "次"
    
62.         crr(j, 9) = "出现"
    
63.         crr(j, 11) = "没有出现"
    
64.         crr(j, 10) = "1234567890"
    
65.         For i = 2 To 8    '找出没有出现的数
    
66.             crr(j, 10) = Replace(crr(j, 10), Val(Mid(crr(j, 2), i, 1)), "")
    
67.         Next
    
68.     Next
    
69.     Sheets("求结果").Range("A2").Resize(m, 11) = crr
    
70.     Application.ScreenUpdating = True
    
71. End Sub

复制代码

原来是求区域内的最大值