[已解决]如何对每列数按要求进行筛查呢？

westwenwei

如何对每列数按要求进行筛查呢？谢谢了！还望各位大神不吝赐教，跪谢了！！！

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2014-2-16 12:22

1. Sub test()
   
2.     Dim arr
   
3.     Dim result
   
4.     arr = Range("a8:v" & Range("a8").End(xlDown).Row).Value
   
5.     Dim i%
   
6.     Application.ScreenUpdating = False
   
7.     Rows("1:7").ClearContents
   
8.     For i = LBound(arr, 2) To UBound(arr, 2)
   
9.         result = getdata(arr, i)
   
10.         If UBound(result) <> -1 Then
    
11.             Cells(1, i).Resize(UBound(result) - LBound(result) + 1).Value = WorksheetFunction.Transpose(result)
    
12.         End If
    
13.     Next
    
14.     Application.ScreenUpdating = True
    
15.     MsgBox "完成", vbInformation
    
16. End Sub
    
17. 
    
18. Function getdata(arr, c1)
    
19.     Dim result
    
20.     Dim r1%
    
21.     Dim str$
    
22.     result = Array(0, 1, 2, 3, 4, 5, 6, 7)
    
23.     For r1 = LBound(arr) To UBound(arr)
    
24.         result(arr(r1, c1)) = r1 & "#"
    
25.     Next
    
26.     getdata = Filter(result, "#", false)
    
27. End Function

复制代码

方法二，用的filter函数实现。

跳转到最佳答案楼层

hwc2ycy

万不一止差3个，你这写的又不够了。
上面最少得留10个空行才是。

hwc2ycy

7个空格也差不多了。
免得写不够破坏了原有的数据。

westwenwei

hwc2ycy 发表于 2014-2-16 11:59
7个空格也差不多了。
免得写不够破坏了原有的数据。

我将问题附件做了一下修改，还请过目，谢谢！！！

hwc2ycy

1. Sub test()
   
2.     Dim arr
   
3.     Dim result
   
4.     arr = Range("a6:v" & Range("a6").End(xlDown).Row).Value
   
5.     Dim i%
   
6.     For i = LBound(arr, 2) To UBound(arr, 2)
   
7.         result = getdata(arr, i)
   
8.         If IsArray(result) Then
   
9.             Cells(1, i).Resize(UBound(result) - LBound(result) + 1).Value = WorksheetFunction.Transpose(result)
   
10.         End If
    
11.     Next
    
12. End Sub
    
13. 
    
14. Function getdata(arr, c1)
    
15.     Dim result(0 To 7) As Boolean
    
16.     Dim r1%
    
17.     Dim str$
    
18.     For r1 = LBound(arr) To UBound(arr)
    
19.         result(arr(r1, c1)) = True
    
20.     Next
    
21.     For r1 = LBound(result) To UBound(result)
    
22.         If Not result(r1) Then
    
23.             str = str & r1 & "#"
    
24.         End If
    
25.     Next
    
26.     If Len(str) Then
    
27.         getdata = Split(Mid(str, 1, Len(str) - 1), "#")
    
28.     Else
    
29.         getdata = False
    
30.     End If
    
31. End Function
    

复制代码

第二列的数据就差了6个，所以你最好在A6上面有7行空的。

hwc2ycy

1. Sub test()
   
2.     Dim arr
   
3.     Dim result
   
4.     arr = Range("a8:v" & Range("a8").End(xlDown).Row).Value
   
5.     Dim i%
   
6.     For i = LBound(arr, 2) To UBound(arr, 2)
   
7.         result = getdata(arr, i)
   
8.         If IsArray(result) Then
   
9.             Cells(1, i).Resize(UBound(result) - LBound(result) + 1).Value = WorksheetFunction.Transpose(result)
   
10.         End If
    
11.     Next
    
12.     MsgBox "完成", vbInformation
    
13. End Sub
    
14. 
    
15. Function getdata(arr, c1)
    
16.     Dim result(0 To 7) As Boolean
    
17.     Dim r1%
    
18.     Dim str$
    
19.     For r1 = LBound(arr) To UBound(arr)
    
20.         result(arr(r1, c1)) = True
    
21.     Next
    
22.     For r1 = LBound(result) To UBound(result)
    
23.         If Not result(r1) Then
    
24.             str = str & r1 & "#"
    
25.         End If
    
26.     Next
    
27.     If Len(str) Then
    
28.         getdata = Split(Mid(str, 1, Len(str) - 1), "#")
    
29.     Else
    
30.         getdata = False
    
31.     End If
    
32. End Function

复制代码

还是上面的代码，只是把A6换成了A8就好了。

hwc2ycy

1. Sub test()
   
2.     Dim arr
   
3.     Dim result
   
4.     arr = Range("a8:v" & Range("a8").End(xlDown).Row).Value
   
5.     Dim i%
   
6.     Application.ScreenUpdating = False
   
7.     Rows("1:7").ClearContents
   
8.     For i = LBound(arr, 2) To UBound(arr, 2)
   
9.         result = getdata(arr, i)
   
10.         If IsArray(result) Then
    
11.             Cells(1, i).Resize(UBound(result) - LBound(result) + 1).Value = WorksheetFunction.Transpose(result)
    
12.         End If
    
13.     Next
    
14.     Application.ScreenUpdating = True
    
15.     MsgBox "完成", vbInformation
    
16. End Sub

复制代码

主过程改了下，先清除原有的数据再输出。

hwc2ycy

1. Sub test()
   
2.     Dim arr
   
3.     Dim result
   
4.     arr = Range("a8:v" & Range("a8").End(xlDown).Row).Value
   
5.     Dim i%
   
6.     Application.ScreenUpdating = False
   
7.     Rows("1:7").ClearContents
   
8.     For i = LBound(arr, 2) To UBound(arr, 2)
   
9.         result = getdata(arr, i)
   
10.         If UBound(result) <> -1 Then
    
11.             Cells(1, i).Resize(UBound(result) - LBound(result) + 1).Value = WorksheetFunction.Transpose(result)
    
12.         End If
    
13.     Next
    
14.     Application.ScreenUpdating = True
    
15.     MsgBox "完成", vbInformation
    
16. End Sub
    
17. 
    
18. Function getdata(arr, c1)
    
19.     Dim result
    
20.     Dim r1%
    
21.     Dim str$
    
22.     result = Array(0, 1, 2, 3, 4, 5, 6, 7)
    
23.     For r1 = LBound(arr) To UBound(arr)
    
24.         result(arr(r1, c1)) = r1 & "#"
    
25.     Next
    
26.     getdata = Filter(result, "#", false)
    
27. End Function

复制代码

方法二，用的filter函数实现。

westwenwei

hwc2ycy 发表于 2014-2-16 12:11
第二列的数据就差了6个，所以你最好在A6上面有7行空的。

我刚才试着运行了一下，发现有点问题，比如A列中少的是1467，可是显示的结果却有23,23在A列中是有的,不需要显示，不知问题出在了哪里，谢谢！

hwc2ycy

westwenwei 发表于 2014-2-16 12:22
我刚才试着运行了一下，发现有点问题，比如A列中少的是1467，可是显示的结果却有23,23在A列中是有的,不需 ...

我这测试是对的。