[已解决]通过VBA实现对EXCEL查找，满足条件的保留，其余删除

sj_dcy

对Excel里数据进行查找，满足PartsData 的，将PartsData及它附属的单元格 保留。其余全部删除。

最佳答案

月排行榜 / 总排行榜

grf1973

2015-9-25 11:31

1. Sub tt()
   
2.     Dim Delrng As Range
   
3.     Set Delrng = Rows(65536)
   
4.     arr = Range("a1:a" & [a65536].End(3).Row)
   
5.     For i = 1 To UBound(arr)
   
6.         If InStr(arr(i, 1), "PartsData") = 0 Then
   
7.             Set Delrng = Union(Delrng, Rows(i))
   
8.         Else
   
9.             For k = i + 1 To UBound(arr)
   
10.                 If Left(Trim(arr(k, 1)), 1) = "[" Then Exit For
    
11.             Next
    
12.             If k < UBound(arr) Then i = k - 1 Else i = k
    
13.         End If
    
14.     Next
    
15.     Delrng.Delete
    
16. End Sub
    

复制代码

跳转到最佳答案楼层

grf1973

1. Sub tt()
   
2.     Dim Delrng As Range
   
3.     Set Delrng = Rows(65536)
   
4.     arr = Range("a1:a" & [a65536].End(3).Row)
   
5.     For i = 1 To UBound(arr)
   
6.         If InStr(arr(i, 1), "PartsData") = 0 Then
   
7.             Set Delrng = Union(Delrng, Rows(i))
   
8.         Else
   
9.             For k = i + 1 To UBound(arr)
   
10.                 If Left(Trim(arr(k, 1)), 1) = "[" Then Exit For
    
11.             Next
    
12.             If k < UBound(arr) Then i = k - 1 Else i = k
    
13.         End If
    
14.     Next
    
15.     Delrng.Delete
    
16. End Sub
    

复制代码

grf1973

请看附件。

sj_dcy

grf1973 发表于 2015-9-25 11:31

你好  要是我想实现 除了 PartsData    PositionData 及其附属单元格 其他都删除，怎么实现。不需要通过点击按钮实现，谢谢了。

grf1973

什么叫不需要通过点击按钮实现？可以在打开工作簿时自动运行下面代码。

1. Sub tt()
   
2.     Dim Delrng As Range
   
3.     Set Delrng = Rows(65536)
   
4.     arr = Range("a1:a" & [a65536].End(3).Row)
   
5.     For i = 1 To UBound(arr)
   
6.         If InStr(arr(i, 1), "PartsData") = 0 And InStr(arr(i, 1), "PositionData") = 0 Then
   
7.             Set Delrng = Union(Delrng, Rows(i))
   
8.         Else
   
9.             For k = i + 1 To UBound(arr)
   
10.                 If Left(Trim(arr(k, 1)), 1) = "[" Then Exit For
    
11.             Next
    
12.             If k < UBound(arr) Then i = k - 1 Else i = k
    
13.         End If
    
14.     Next
    
15.     Delrng.Delete
    
16. End Sub

复制代码

grf1973

这样一打开文件就把多余的行删掉了。

1. Private Sub Workbook_Open()
   
2.     Dim Delrng As Range
   
3.     With Sheet1
   
4.         Set Delrng = .Rows(65536)
   
5.         arr = .Range("a1:a" & .[a65536].End(3).Row)
   
6.         For i = 1 To UBound(arr)
   
7.             If InStr(arr(i, 1), "PartsData") = 0 And InStr(arr(i, 1), "PositionData") = 0 Then
   
8.                 Set Delrng = Union(Delrng, .Rows(i))
   
9.             Else
   
10.                 For k = i + 1 To UBound(arr)
    
11.                     If Left(Trim(arr(k, 1)), 1) = "[" Then Exit For
    
12.                 Next
    
13.                 If k < UBound(arr) Then i = k - 1 Else i = k
    
14.             End If
    
15.         Next
    
16.         Delrng.Delete
    
17.     End With
    
18. End Sub
    

复制代码

sj_dcy

grf1973 发表于 2015-9-25 14:15
什么叫不需要通过点击按钮实现？可以在打开工作簿时自动运行下面代码。

这一个就行，谢谢了。