EXCEL 实现所有子表条件筛选汇总到新表

1. 经常我们会需要将一个工作簿中所有子表里满足某些条件的行或列进行筛选汇总到一个新的表格里，如果靠人力去逐条筛查，表格数据少还可以接受，但是数据表多了之后显然不太现实。这里就给大家提供一种可以进行快速汇总的方法。如果你是VBA大神，直接看代码部分就行。如果基础比较弱，可以跟着一起尝试做一遍。首先可以试着做一个样表进行试验。表格演示提供大家一个演示：
   
2. 根据样表大家可以复制出多几个类似的样表，那么关键问题来了，如何对这些格式相同的子表进行筛选汇总呢。要解决这个问题，首先需要确定你要筛选的条件依据，本例中选择延期天数和状态进行筛选。如下

If sh.Cells(x, 10) >= -1 And sh.Cells(x, 10) <> "" And sh.Cells(x, 11) <> "关闭" Then
                Set CopyRng = sh.Range(sh.Rows(x), sh.Rows(x))

3.当然我们最后想要的是将所有的子表中满足条件的行全部汇总到提醒表汇总起来。那么为了能实现遍历表格的子表，可以使用新增名称管理器的方法设定数据引用位置= GET.WORKBOOK（1），新增名称管理器的方法可以自行上网查询。获取到字表名称后就可以根据表名利用对于循环进行遍历所有表格，然后嵌套第二步的判断条件，实现对所有的表格进行筛选。为了方便，直接将所有表格按序号进行命名。

For Each sh In Sheets(Array("1.","2.","3."))
        firstblankrow = sh.Range("B1").End(xlDown).Row - 1
        StartRow = 2
        If firstblankrow > 0 And firstblankrow > StartRow Then
            For x = 2 To firstblankrow + 1
                If sh.Cells(x, 10) >= -1 And sh.Cells(x, 10) <> "" And sh.Cells(x, 11) <> "关闭" Then
                Set CopyRng = sh.Range(sh.Rows(x), sh.Rows(x))

1. Ok 到此就可以基本实现所有功能。附上完整代码供参考：

Private Sub Worksheet_Activate()
        Dim sh As Worksheet
        Dim DeSh As Worksheet
        Dim x As Integer
        Dim StartRow As Long
        Dim Last As Long
        Dim shLast As Long
        Dim firstblankrow As Long
        Dim CopyRng As Range
        On Error Resume Next

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    Set DeSh = Me
    Last = LastRow(DeSh)
    If Last >= 4 Then
        Rows("5:" & Last).Delete
    End If
    Last = 4
    For Each sh In Sheets(Array("1.","2.","3."))
        firstblankrow = sh.Range("B1").End(xlDown).Row - 1
        StartRow = 2
        If firstblankrow > 0 And firstblankrow > StartRow Then
            For x = 2 To firstblankrow + 1
                If sh.Cells(x, 10) >= -1 And sh.Cells(x, 10) <> "" And sh.Cells(x, 11) <> "关闭" Then
                Set CopyRng = sh.Range(sh.Rows(x), sh.Rows(x))

                CopyRng.Copy
                With DeSh.Cells(Last + 1, "A")
                    .PasteSpecial xlPasteValues
                    .PasteSpecial xlPasteFormats
                    Application.CutCopyMode = xlCopy
                    DeSh.Cells(Last + 1, LastColumn(DeSh)).Select
                    DeSh.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:="'" & sh.Name & "'" & "!A1", TextToDisplay:=sh.Name '此处是为了方便定位AP创建的超链接到该AP所属的原子表
                End With
                Last = LastRow（DeSh）
                End If If 
            Next 
        End If 
    Next
Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.DisplayAlerts = True

ExitSub:
    Application.Goto DeSh.Cells(1)
    DestSh.Columns.AutoFit
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.DisplayAlerts = True
End Sub

另外模块中还用到了两个自定义函数，分别用来定位最后一行和最后一列的序号。代码如下：

Function LastRow(sh As Worksheet)
    On Error Resume Next

    LastRow = sh.Cells.Find(what:="*", after:=sh.Range("A1"), lookat:=xlPart, LookIn:=xlFormulas, searchorder:=xlByRows, searchdirection:=xlPrevious, MatchCase:=False).Row

End Function


Function LastColumn(sh As Worksheet)
    On Error Resume Next

    LastColumn = sh.Cells.Find(what:="*", after:=sh.Range("A1"), lookat:=xlPart, LookIn:=xlFormulas, searchorder:=xlByColumns, searchdirection:=xlPrevious, MatchCase:=False).Column

End Function

1. 到这里所有的功能就可以实现了，第一次写，不对之处还请包涵。大家可以尝试一下，如果有疑问可以在评论区留言交流，上班族回复不及时还请见谅，谢谢~~