[已解决]请教一个数据筛选的例子，谢谢！

hwc2ycy

循环嵌套多了，不过针对第二种方法，原来就需要2次循环，像你带/的号，也要多种情况，考虑到上下，前后，4层差不多，但很多实现，第3层循环只跑一次。

hwc2ycy

写了这么多，你可别忘了给最佳呀。累死我了。

喜气洋洋

hwc2ycy 发表于 2013-6-3 16:29
写了这么多，你可别忘了给最佳呀。累死我了。

绝对的最佳 真心感谢你

不过 运行到

ReDim arrResult(1 To (UBound(arr) + LBound(arr)) * UBound(arr) / 2 + 1, 1 To 2)

提示“内存溢出”，不知道为啥，求大师指点。

hwc2ycy

你暂停后看看，ARR的类型，在本地窗口里。
你的数据量很大还是？

喜气洋洋

hwc2ycy 发表于 2013-6-3 18:01
你暂停后看看，ARR的类型，在本地窗口里。
你的数据量很大还是？

数据是6000多条
有的电脑能运行 有的电脑提示内存溢出
内存 都是2G的


Book11.rar (148.75 KB, 下载次数: 2)

2013-6-3 21:04 上传

点击文件名下载附件

hwc2ycy

版本呢?
这种情况我以前有同学也碰到过。

喜气洋洋

hwc2ycy 发表于 2013-6-3 21:05
版本呢?
这种情况我以前有同学也碰到过。

我的是07版本的 可以运行
有几台是07版本的 不能运行
有个台式机 10版本的 也不能运行
总之 除了我的电脑 其他都是提示内存溢出

hwc2ycy

数组换成静态的。
6000*6000/2，数组大小36000000/2，这个数组确实有点大了。

1. Sub 同一基站方向小于20度()
   
2. '匹配数字
   
3.     Dim arr, arrResult(1 To 655535, 1 To 2)
   
4.     Dim lRecord As Long
   
5.     Dim i As Long, j As Long
   
6.     Dim str1 As String
   
7.     Dim lAbs As Long
   
8. 
   
9.     Dim objRegExp1 As Object, objRegExp2 As Object
   
10.     Dim item1, item2
    
11.     Set objRegExp1 = CreateObject("VBScript.regExp")
    
12.     Set objRegExp2 = CreateObject("VBScript.regExp")
    
13. 
    
14.     With objRegExp1
    
15.         .Global = True
    
16.         .Pattern = "\d+"
    
17.     End With
    
18. 
    
19.     With objRegExp2
    
20.         .Global = True
    
21.         .Pattern = "\d+"
    
22.     End With
    
23. 
    
24. 
    
25.     '源数据
    
26.     With Sheet2
    
27.         arr = .Range("a1").CurrentRegion
    
28.     End With
    
29. 
    
30.     '结果数组
    
31.     'ReDim arrResult(1 To 655535, 1 To 2)
    
32.     arrResult(1, 1) = "site"
    
33.     arrResult(1, 2) = "角度差"
    
34. 
    
35.     '标题占一行
    
36.     lRecord = 1
    
37.     '数组行循环
    
38.     For i = LBound(arr) + 1 To UBound(arr) - 1
    
39.         str1 = Mid(arr(i, 1), 3, 4)
    
40.         For j = i + 1 To UBound(arr)
    
41.             '相同的循环并且要求行值
    
42.             If (str1 = Mid(arr(j, 1), 3, 4)) Then
    
43.                 For Each item1 In objRegExp1.Execute(arr(i, 3))
    
44.                     For Each item2 In objRegExp2.Execute(arr(j, 3))
    
45.                         lAbs = Abs(Val(item1) - Val(item2))
    
46.                         If lAbs <= 20 Then
    
47.                             lRecord = lRecord + 1
    
48.                             arrResult(lRecord, 1) = arr(i, 1) & "-" & arr(j, 1)
    
49.                             arrResult(lRecord, 2) = lAbs
    
50.                         End If
    
51.                     Next
    
52.                 Next
    
53.             End If
    
54.         Next
    
55.     Next
    
56. 
    
57.     With Sheet3
    
58.         .Range("f1").Resize(lRecord, 2).Value = arrResult
    
59.     End With
    
60.     MsgBox "整理完成", vbInformation + vbOKOnly
    
61. End Sub

复制代码

hwc2ycy

结果下来，也只有1000多行数据，

喜气洋洋

hwc2ycy 发表于 2013-6-3 21:13
结果下来，也只有1000多行数据，

我在想 是不是 将条件扩展到 1-6个字母相同的时候 才比较 就可以减少一半的对比了
我手工做了一下 才200多条 这样 就40000多 应该每台电脑都可以出来了
36000000 为什么你电脑能运行 他们电脑不行。。。
将我的分 都奖励给你先  {:1112:}