大量正负成对数据，需要删除这些行，求帮助

绿豆汤汤

图片

如图，大量这样的成对的 正负 数据，现需全部删除这些行，数量太大，请大家帮助~
看了下 都是一对一的数据，有些是隔行的 谢谢大家~

chxw68

1. Sub test2()
   
2.   Dim r%, i%, j%, k%
   
3.   Dim arr
   
4.   Dim rng As Range
   
5.   With Worksheets("f30180669")
   
6.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
7.     arr = .Range("a1:f" & r)
   
8.     ReDim brr(1 To UBound(arr), 1 To 1)
   
9.     For i = 3 To UBound(arr) - 1
   
10.       If brr(i, 1) <> 1 Then
    
11.         For j = i + 1 To UBound(arr)
    
12.           If brr(j, 1) <> 1 Then
    
13.             If arr(i, 1) + arr(j, 1) = 0 Then
    
14.               For k = 2 To UBound(arr, 2)
    
15.                 If arr(i, k) + arr(j, k) <> 0 Then
    
16.                   Exit For
    
17.                 End If
    
18.               Next
    
19.               If k > UBound(arr, 2) Then
    
20.                 brr(i, 1) = 1
    
21.                 brr(j, 1) = 1
    
22.                 Exit For
    
23.               End If
    
24.             End If
    
25.           End If
    
26.         Next
    
27.       End If
    
28.     Next
    
29.     Set rng = .Rows(r + 1)
    
30.     For i = 1 To UBound(brr)
    
31.       If brr(i, 1) = 1 Then
    
32.         Set rng = Union(rng, .Rows(i))
    
33.       End If
    
34.     Next
    
35.     rng.Select
    
36.     'rng.Delete
    
37.   End With
    
38. End Sub
    
39. 
    

复制代码

chxw68

用的两重循环笨办法，能能够实现楼主要求，但速度比较慢。后面再琢磨其他办法。

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As New Dictionary
   
5.   Dim d1 As New Dictionary
   
6.   Dim d2 As New Dictionary
   
7.   t = Timer
   
8.   With Worksheets("f30180669")
   
9.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
10.     arr = .Range("a1:f" & r)
    
11.     For i = 3 To UBound(arr)
    
12.       If arr(i, 1) < 0 Then
    
13.         d1(i) = ""
    
14.       Else
    
15.         d2(i) = ""
    
16.       End If
    
17.     Next
    
18.   End With
    
19.   For Each aa In d1.Keys
    
20.     For Each bb In d2.Keys
    
21.       If arr(aa, 1) + arr(bb, 1) = 0 Then
    
22.         For j = 2 To 6
    
23.           If arr(aa, j) + arr(bb, j) <> 0 Then
    
24.             Exit For
    
25.           End If
    
26.         Next
    
27.         If j > 6 Then
    
28.           d(aa) = ""
    
29.           d(bb) = ""
    
30.           d2.Remove (bb)
    
31.           Exit For
    
32.         End If
    
33.       End If
    
34.     Next
    
35.   Next
    
36.   With Worksheets("f30180669")
    
37.     Set rng = .Rows(r + 1)
    
38.     For Each aa In d.Keys
    
39.       Set rng = Union(rng, .Rows(aa))
    
40.     Next
    
41.     rng.Select
    
42.   End With
    
43.   MsgBox Timer - t
    
44. End Sub
    

复制代码

chxw68

呵呵，改变了程序设计思路，程序运行时间由2楼的54秒提升到现在的不到3秒，提升幅度还是很明显的。

绿豆汤汤

chxw68 发表于 2015-3-24 18:02
呵呵，改变了程序设计思路，程序运行时间由2楼的54秒提升到现在的不到3秒，提升幅度还是很明显的。

谢谢大神，太好了！！ 咱还得从基本的学起~

绿豆汤汤

chxw68 发表于 2015-3-24 18:02
呵呵，改变了程序设计思路，程序运行时间由2楼的54秒提升到现在的不到3秒，提升幅度还是很明显的。

老师，您好！谢谢您的帮助，您的程序很简洁适用。由于有些个人资料问题，我上传的附件并不完整，但是我目前还不会根据您的程序套用，能不能请您帮助处理下完整版的数据？非常感谢！我如何发送给您

chxw68

绿豆汤汤 发表于 2015-3-25 14:13
老师，您好！谢谢您的帮助，您的程序很简洁适用。由于有些个人资料问题，我上传的附件并不完整，但是我目 ...

1025348239@qq.com

yjh_27

要准确对冲，还需ID限制，仅有数据判断会出差错。

绿豆汤汤

yjh_27 发表于 2015-3-25 15:55
要准确对冲，还需ID限制，仅有数据判断会出差错。

谢谢您，可以求个邮箱吗~