[已解决]请帮助解决《查询整数范围》问题

yizhih

请帮助解决《查询整数范围》问题，谢谢！
查询整数范围.rar (13.71 KB, 下载次数: 15)

2013-1-2 15:21 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

suye1010

2013-1-2 21:50

1. 
   
2. <P>Sub Test()
   
3. Dim d0, d1, i As Integer, j As Integer, k As Integer, l As Integer, arr, arr1(1 To 13, 1 To 6), ToNo, KC, t
   
4. t = Timer
   
5. On Error Resume Next
   
6. arr = Range("F3:F" & Range("F65536").End(xlUp).Row)
   
7. Set d0 = CreateObject("Scripting.Dictionary")
   
8. Set d1 = CreateObject("Scripting.Dictionary")
   
9. For j = 3 To 15
   
10.     For i = 1 To UBound(arr) - j + 1
    
11.         ToNo = 0
    
12.         For l = 1 To j
    
13.             ToNo = ToNo + arr(i + l - 1, 1)
    
14.         Next l
    
15.         temp = Round(IIf(ToNo / j >= 1, ToNo / j, 0), 0)
    
16.                 d0(temp) = d0(temp) + 1
    
17.     Next i
    
18.     For Each KC In d0.Keys
    
19.         d1.Add d0(KC) * 100 + KC, IIf(KC, "'" & KC - 1 & "-" & KC + 1, "'0-1")
    
20.     Next
    
21.     For k = 1 To 3
    
22.         arr1(j - 2, 2 * k - 1) = d1(Application.Large(d1.Keys, k))
    
23.         arr1(j - 2, 2 * k) = Application.Large(d1.Keys, k) \ 100
    
24.     Next k
    
25.     d0.RemoveAll
    
26.     d1.RemoveAll
    
27. Next j
    
28. Cells(5, "Q").Resize(13, 6) = arr1
    
29. MsgBox "总共耗时" & Timer - t & "s", vbInformation + vbOKOnly
    
30. End Sub
    
31. </P>

复制代码

查询整数范围-1.rar (25.41 KB, 下载次数: 3, 售价: 1 个金币)

2013-1-3 11:12 上传

点击文件名下载附件

跳转到最佳答案楼层

hoogle

查询整数范围.zip (23.27 KB, 下载次数: 7)

2013-1-2 21:04 上传

点击文件名下载附件

suye1010

1. 
   
2. <P>Sub Test()
   
3. Dim d0, d1, i As Integer, j As Integer, k As Integer, l As Integer, arr, arr1(1 To 13, 1 To 6), ToNo, KC, t
   
4. t = Timer
   
5. On Error Resume Next
   
6. arr = Range("F3:F" & Range("F65536").End(xlUp).Row)
   
7. Set d0 = CreateObject("Scripting.Dictionary")
   
8. Set d1 = CreateObject("Scripting.Dictionary")
   
9. For j = 3 To 15
   
10.     For i = 1 To UBound(arr) - j + 1
    
11.         ToNo = 0
    
12.         For l = 1 To j
    
13.             ToNo = ToNo + arr(i + l - 1, 1)
    
14.         Next l
    
15.         temp = Round(IIf(ToNo / j >= 1, ToNo / j, 0), 0)
    
16.                 d0(temp) = d0(temp) + 1
    
17.     Next i
    
18.     For Each KC In d0.Keys
    
19.         d1.Add d0(KC) * 100 + KC, IIf(KC, "'" & KC - 1 & "-" & KC + 1, "'0-1")
    
20.     Next
    
21.     For k = 1 To 3
    
22.         arr1(j - 2, 2 * k - 1) = d1(Application.Large(d1.Keys, k))
    
23.         arr1(j - 2, 2 * k) = Application.Large(d1.Keys, k) \ 100
    
24.     Next k
    
25.     d0.RemoveAll
    
26.     d1.RemoveAll
    
27. Next j
    
28. Cells(5, "Q").Resize(13, 6) = arr1
    
29. MsgBox "总共耗时" & Timer - t & "s", vbInformation + vbOKOnly
    
30. End Sub
    
31. </P>

复制代码

查询整数范围-1.rar (25.41 KB, 下载次数: 3, 售价: 1 个金币)

2013-1-3 11:12 上传

点击文件名下载附件

yizhih

suye1010 发表于 2013-1-2 21:50

妙，太好了，非常感谢suye1010 老师，再请教一下老师，能否加上各整数范围的次数，请老师费心了。

yizhih

suye1010 发表于 2013-1-2 21:50

suye1010老师，可能是我没有说清楚，还是有点问题，请老师再看一下，修改了一下附件。
原来500多行不易看清楚，现在我改为11行，便于看的清楚，但实际用起来还是要500多行。
查询整数范围-1.rar (24.82 KB, 下载次数: 2)

2013-1-2 23:26 上传

点击文件名下载附件

yizhih

suye1010 发表于 2013-1-2 21:50

非常好，感谢 suye1010 老师。

yizhih

hoogle 发表于 2013-1-2 20:57

谢谢hoogle老师。