[已解决]求大神帮忙，vba根据excel内容筛选很急

ctmss

如附件所示，小弟需要根据“性别”表中的定义将表“名单1”“名单2”中的相应内容进行筛选。
如“性别”表中“性别”选为男，那么表“名单1”“名单2”自动筛选性别为男的行（女的行删掉或隐藏）。
求大神指点，不甚感激！

最佳答案

月排行榜 / 总排行榜

苏子龙

2016-11-23 11:34

1. Private Sub Worksheet_Change(ByVal T As Range)
   
2. Dim arr(0 To 60000, 1 To 3), stmArr, n As Integer
   
3. Dim strPath As String, i As Long, strName As String
   
4. Dim wb As Workbook, wbName As String, sh As Worksheet
   
5. 
   
6. If T.Address <> "$A$2" Then Exit Sub '当不是A2单元格时，退出
   
7. Application.ScreenUpdating = False
   
8. strPath = ThisWorkbook.Path & ""
   
9. strName = Dir(strPath & "*.XLS*")
   
10. arr(0, 1) = "姓名": arr(0, 2) = "性别": arr(0, 3) = "工作簿名称"
    
11. Do While strName <> ""
    
12.     wbName = Split(strName, ".")(0)
    
13.     If wbName <> "性别" Then
    
14.        Set wb = Workbooks.Open(strPath & strName)
    
15.        For Each sh In wb.Sheets
    
16.             If sh.Range("a1") = "" Then GoTo 10
    
17.             stmArr = sh.UsedRange
    
18.             For n = 1 To UBound(stmArr)
    
19.                 If stmArr(n, 2) = T.Value Then
    
20.                 i = i + 1
    
21.                 arr(i, 1) = stmArr(n, 1)
    
22.                 arr(i, 2) = stmArr(n, 2)
    
23.                 arr(i, 3) = wbName
    
24.                 End If
    
25. 10
    
26.             Next
    
27.         Next
    
28.         wb.Close: Set wb = Nothing
    
29.     End If
    
30.     strName = Dir
    
31. Loop
    
32. Range("b2:d60002") = arr
    
33. Application.ScreenUpdating = True
    
34. End Sub

复制代码

跳转到最佳答案楼层

苏子龙

就用筛选就可以了

ctmss

苏子龙 发表于 2016-11-23 07:03
就用筛选就可以了

因为表格很多，有好几十张，所以人工筛选很慢~

ctmss

ctmss 发表于 2016-11-23 07:44
因为表格很多，有好几十张，所以人工筛选很慢~

而且筛选条件有好几个，所以想有个例子自己再改一下

望帝春心

为什么不放到一个工作薄？

ctmss

望帝春心 发表于 2016-11-23 07:45
为什么不放到一个工作薄？

因为原始文件就是好几张表，每张表有不同的页我只需要处理不同表的同一页，由于原始文件不能上传，所以模拟了个比较简单的情况，自己再来修改。

望帝春心

ctmss 发表于 2016-11-23 08:28
因为原始文件就是好几张表，每张表有不同的页我只需要处理不同表的同一页，由于原始文件不能上传，所以模 ...

我是新手，不太会，等 大神出手相助吧

苏子龙

1. Private Sub Worksheet_Change(ByVal T As Range)
   
2. Dim arr(0 To 60000, 1 To 3), stmArr, n As Integer
   
3. Dim strPath As String, i As Long, strName As String
   
4. Dim wb As Workbook, wbName As String, sh As Worksheet
   
5. 
   
6. If T.Address <> "$A$2" Then Exit Sub '当不是A2单元格时，退出
   
7. Application.ScreenUpdating = False
   
8. strPath = ThisWorkbook.Path & ""
   
9. strName = Dir(strPath & "*.XLS*")
   
10. arr(0, 1) = "姓名": arr(0, 2) = "性别": arr(0, 3) = "工作簿名称"
    
11. Do While strName <> ""
    
12.     wbName = Split(strName, ".")(0)
    
13.     If wbName <> "性别" Then
    
14.        Set wb = Workbooks.Open(strPath & strName)
    
15.        For Each sh In wb.Sheets
    
16.             If sh.Range("a1") = "" Then GoTo 10
    
17.             stmArr = sh.UsedRange
    
18.             For n = 1 To UBound(stmArr)
    
19.                 If stmArr(n, 2) = T.Value Then
    
20.                 i = i + 1
    
21.                 arr(i, 1) = stmArr(n, 1)
    
22.                 arr(i, 2) = stmArr(n, 2)
    
23.                 arr(i, 3) = wbName
    
24.                 End If
    
25. 10
    
26.             Next
    
27.         Next
    
28.         wb.Close: Set wb = Nothing
    
29.     End If
    
30.     strName = Dir
    
31. Loop
    
32. Range("b2:d60002") = arr
    
33. Application.ScreenUpdating = True
    
34. End Sub

复制代码