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

喜气洋洋

筛选出，第3-6个字母之间相同的site对应的角度差绝对值小于20度的记录

附件中含详细的操作步骤，有数据，有例子，有步骤，有例子结果，谢谢大家！

数据 例子，谢谢.rar (19.74 KB, 下载次数: 13)

2013-6-3 08:14 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-6-3 21:49

既然不多，你就也可以直接就改成源数据大小相同也成。

1. Sub 同一基站方向小于20度()
   
2. '匹配数字
   
3.     Dim arr, arrResult()
   
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 UBound(arr) + 1, 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
    

复制代码

跳转到最佳答案楼层

喜气洋洋

请问是我表达得不清楚么，我是想筛选出里面相互间夹角小于20度的数据，请大师指点！

hwc2ycy

1. Sub test()
   
2.     Dim arr, arrResult()
   
3.     Dim lRecord As Long
   
4.     Dim i As Long
   
5.    
   
6.     With Sheet2
   
7.         arr = .Range("a1").CurrentRegion
   
8.     End With
   
9.    
   
10.     ReDim arrResult(1 To UBound(arr) + 1, 1 To 2)
    
11.     arrResult(1, 1) = "site"
    
12.     arrResult(1, 2) = "角度差"
    
13. 
    
14.     lRecord = 1
    
15.     For i = LBound(arr) + 1 To UBound(arr) - 1
    
16.         Debug.Print Mid(arr(i, 1), 3, 4), Mid(arr(i + 1, 1), 3, 4), i
    
17.         Do While (Mid(arr(i, 1), 3, 4) = Mid(arr(i + 1, 1), 3, 4)) And i < UBound(arr)
    
18.             Debug.Print Mid(arr(i, 1), 3, 4), Mid(arr(i + 1, 1), 3, 4), i
    
19.             If IsNumeric(arr(i, 3)) And IsNumeric(arr(i + 1, 3)) Then
    
20. 
    
21.                 If Abs(arr(i, 3) - arr(i + 1, 3)) <= 20 Then
    
22.                     lRecord = lRecord + 1
    
23.                     arrResult(lRecord, 1) = arr(i, 1) & "-" & arr(i + 1, 1)
    
24.                     arrResult(lRecord, 2) = Abs(arr(i, 3) - arr(i + 1, 3))
    
25.                 End If
    
26.             End If
    
27.             i = i + 1
    
28.             If i = 18 Then Exit For
    
29.         Loop
    
30.         'i = i - 1
    
31.     Next
    
32.     With Sheet3
    
33.         .Range("f1").Resize(lRecord, 2).Value = arrResult
    
34.     End With
    
35.     MsgBox "整理完成", vbInformation + vbOKOnly
    
36. 
    
37. End Sub

复制代码

hwc2ycy

结果跟你模拟的数据是一样的。
你再多用些数据测测吧。

hwc2ycy

1. Sub test()
   
2.     Dim arr, arrResult()
   
3.     Dim lRecord As Long
   
4.     Dim i As Long
   
5.    
   
6.     '源数据
   
7.     With Sheet2
   
8.         arr = .Range("a1").CurrentRegion
   
9.     End With
   
10.    
    
11.     '结果数组
    
12.     ReDim arrResult(1 To UBound(arr) + 1, 1 To 2)
    
13.     arrResult(1, 1) = "site"
    
14.     arrResult(1, 2) = "角度差"
    
15.    
    
16.     '标题占一行
    
17.     lRecord = 1
    
18.     '数组行循环
    
19.     For i = LBound(arr) + 1 To UBound(arr) - 1
    
20.         '相同的循环并且要求行值
    
21.         Do While (Mid(arr(i, 1), 3, 4) = Mid(arr(i + 1, 1), 3, 4)) And i < UBound(arr) - 1
    
22.             '先判断是否是数值，否则不做处理
    
23.             If IsNumeric(arr(i, 3)) And IsNumeric(arr(i + 1, 3)) Then
    
24.                 '判断绝对值
    
25.                 If Abs(arr(i, 3) - arr(i + 1, 3)) <= 20 Then
    
26.                     lRecord = lRecord + 1
    
27.                     arrResult(lRecord, 1) = arr(i, 1) & "-" & arr(i + 1, 1)
    
28.                     arrResult(lRecord, 2) = Abs(arr(i, 3) - arr(i + 1, 3))
    
29.                 End If
    
30.             End If
    
31.             '行号自加1，继续循环
    
32.             i = i + 1
    
33.         Loop
    
34.     Next
    
35.    
    
36.     With Sheet3
    
37.         .Range("f1").Resize(lRecord, 2).Value = arrResult
    
38.     End With
    
39.     MsgBox "整理完成", vbInformation + vbOKOnly
    
40. End Sub
    

复制代码

hwc2ycy

喜气洋洋

hwc2ycy 发表于 2013-6-3 09:54

嗯嗯，谢谢班级管理员的热心帮忙，我学习一下代码
运行很快，谢谢！
如果将结果修改为，不只是1与2，2与3,3与4。。。之间有对比，1与2,1与3,1与4之间也有对比，如下面的结果：



这样代码应该做怎样的修改呢，谢谢您！

Book11.rar (13.5 KB, 下载次数: 4)

2013-6-3 10:43 上传

点击文件名下载附件

hwc2ycy

那就是多层循环了。
外面再套一层循环。

喜气洋洋

hwc2ycy 发表于 2013-6-3 10:50
那就是多层循环了。
外面再套一层循环。

就是 需要先计算每一个 Mid(arr(i, 1), 3, 4) 相同的数量，然后 从1循环到 这个数量么？

喜气洋洋

hwc2ycy 发表于 2013-6-3 10:50
那就是多层循环了。
外面再套一层循环。

好像没有对  30/110/300 这种形式的数据进行处理
这样，如果是 30/40/300 也不会筛选出来