[已解决]用VBA做复杂的筛选。

大灰狼1976

这样行不行，你试一下。

1. Sub aaa()
   
2. Dim arr, brr, i&, j&, ar1, ar2, ar3, s1$, s2$, s3$, r&, n&
   
3. arr = [f1].CurrentRegion
   
4. ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
   
5. ar1 = [f1000].Resize(10, UBound(arr, 2))
   
6. ar2 = [f1011].Resize(10, UBound(arr, 2))
   
7. ar3 = [f1022].Resize(10, UBound(arr, 2))
   
8. For j = 1 To UBound(arr, 2)
   
9.   r = 0
   
10.   s1 = Join(Application.Transpose(Application.Index(ar1, , j)), "")
    
11.   s2 = Join(Application.Transpose(Application.Index(ar2, , j)), "")
    
12.   s3 = Join(Application.Transpose(Application.Index(ar3, , j)), "")
    
13.   For i = 1 To UBound(arr)
    
14.     If arr(i, j) = "" Then Exit For
    
15.     If InStr(s1, Left(arr(i, j), 1)) = 0 And InStr(s2, Mid(arr(i, j), 2, 1)) = 0 And InStr(s3, Right(arr(i, j), 1)) = 0 Then
    
16.       r = r + 1
    
17.       If n < r Then n = r
    
18.       brr(r, j) = arr(i, j)
    
19.     End If
    
20.   Next i
    
21. Next j
    
22. [f1035].CurrentRegion.ClearContents
    
23. [f1035].Resize(n, UBound(brr, 2)) = brr
    
24. End Sub

复制代码

mate88

大灰狼1976 发表于 2017-10-28 10:55
这样行不行，你试一下。

不知道为什么，一运行代码，就不动了。点执行是灰色的。点不动。

大灰狼1976

我下载试了一下没有问题呀

大灰狼1976

你把aaa后面的2去掉试试，后面跟数字有时会出问题，规律不明。

mate88

大灰狼1976 发表于 2017-10-28 11:12
我下载试了一下没有问题呀

我按ALT+F8，就出现这个：

mate88

大灰狼1976 发表于 2017-10-28 11:14
你把aaa后面的2去掉试试，后面跟数字有时会出问题，规律不明。

你好老师。可否帮忙再看下。

exc姜

学习

大灰狼1976

1. Sub aaa()
   
2. Dim arr, brr, i&, j&, ar1, ar2, ar3, s1$, s2$, s3$, r&, n&
   
3. Dim c&
   
4. For i = 1000 To 1022 Step 11
   
5.   If c < Cells(i, Columns.Count).End(1).Column Then c = Cells(i, Columns.Count).End(1).Column
   
6. Next i
   
7. c = c - 5
   
8. arr = [f1].CurrentRegion
   
9. ReDim brr(1 To UBound(arr), 1 To c)
   
10. ar1 = [f1000].Resize(10, UBound(arr, 2))
    
11. ar2 = [f1011].Resize(10, UBound(arr, 2))
    
12. ar3 = [f1022].Resize(10, UBound(arr, 2))
    
13. For j = 1 To c
    
14.   r = 0
    
15.   s1 = Join(Application.Transpose(Application.Index(ar1, , j)), "")
    
16.   s2 = Join(Application.Transpose(Application.Index(ar2, , j)), "")
    
17.   s3 = Join(Application.Transpose(Application.Index(ar3, , j)), "")
    
18.   For i = 1 To UBound(arr)
    
19.     If arr(i, j) = "" Then Exit For
    
20.     If InStr(s1, Left(arr(i, j), 1)) = 0 And InStr(s2, Mid(arr(i, j), 2, 1)) = 0 And InStr(s3, Right(arr(i, j), 1)) = 0 Then
    
21.       r = r + 1
    
22.       If n < r Then n = r
    
23.       brr(r, j) = arr(i, j)
    
24.     End If
    
25.   Next i
    
26. Next j
    
27. [f1035].CurrentRegion.ClearContents
    
28. [f1035].Resize(n, c) = brr
    
29. End Sub

复制代码