Excel VBA 多条件筛选 AdvancedFilter 汇总统计 sumproduct Range与Array交换

       在日常工作中，面对Excel表格数据，为了分类进行统计，通过对表格数据筛选获取分类条目，再按条目实行汇总统计。要完成上面的工作，有人工操作和开发程序两种方法，本文通过一个有10000行数据的管线调查表，对不同管径、管材进行分类统计数量和长度，详细介绍人工操作和VBA程序开发这两种方法。

1、人工操作方法

1.1高级筛选

        Excel菜单：数据-高级  找开高级筛选对话框，如下图：

        对话框中：  方式：将筛选 结果复制到其他位置

                     列表区域： 选择需要筛选 的区域

                        复制到：筛选结果粘贴位置（没有数据的空白区域）

                     选择不重复的记录：打钩

        确定后得到的结果如下图

 1.2分类统计

        在P2单元格输入公式：=SUMPRODUCT((H:H=N2)*(I:I=O2),L:L)

        在Q2单元格输入公式：=SUMPRODUCT((H:H=N2)*(I:I=O2))

        以此类推就可以计算出所有统计数据

2、VBA编程的方法

        虽然人工操作方法也很方便，但当我们利用程序处理一系列复杂工作的同时，要进行分类统计时，就无法使用人工操作方法了。所以还要讨论一下编程的方法。利用Excel的VBA二次开发编写程序，实现多条件筛选分类统计可以有多种方法，本文介绍宏表函数法的数组法二种方法。

2.1宏表函数法

        宏表函数法就是人工操作法录制宏，再对宏进行修改的方法。先做统计条目的筛选，对筛选结果进行排序，最后进行统计计算。代码如下：

Sub 多条件筛选汇总统计()  '利用宏表函数进行多条件筛选汇总统计用约：最大行设10000时0.1秒；用整列计算用时1.46秒
Dim 筛选数据区域 As Range
Dim 复制区域 As Range
Dim 总长 As Double
Sheets("Sheet1").Select
sngStart = Timer
Set 筛选数据区域 = Range(Cells(1, 8), Cells(10000, 9))
Range(Cells(1, 14), Cells(30, 17)).Clear
Set 目标区域 = Range(Cells(1, 14), Cells(1, 14))
筛选数据区域.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=目标区域, Unique:=True
'排序
With ActiveSheet.Sort
    .SortFields.Clear
    .SortFields.Add Key:=Range("N2:N10000"), SortOn:=0, Order:=1, DataOption:=0
    .SortFields.Add Key:=Range("O2:O10000"), SortOn:=0, Order:=1, DataOption:=0
    .SetRange Range("N2:O10000")
    .Header = xlGuess
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin      'xlPinYin 表示按照首字母 排序   xlStroke 表示按每个字符的笔划数量排序。
    .Apply
End With
i = 2
Do While Cells(i, 14) <> ""   '利用宏表函数进行统计汇总
    '预先能知道最大值时，条件式及统计项均使用最大值，可提高运算速度,用时 0.1 秒
    Cells(i, 16) = "=SUMPRODUCT((R2C8:R20000C8=R" + Trim(str(i)) + "C14)*(R2C9:R20000C9=R" + Trim(str(i)) + "C15),R2C12:R20000C12)"
    Cells(i, 17) = "=SUMPRODUCT((R2C8:R20000C8=R" + Trim(str(i)) + "C14)*(R2C9:R20000C9=R" + Trim(str(i)) + "C15))"
    
    '预先不知道有多少行时，条件式及统计项均使用整列，会降低运算速度,用时 1.46 秒
    'Cells(i, 16) = "=SUMPRODUCT((C8:C8=R" + Trim(str(i)) + "C14)*(C9:C9=R" + Trim(str(i)) + "C15),C12:C12)"
    'Cells(i, 17) = "=SUMPRODUCT((C8:C8=R" + Trim(str(i)) + "C14)*(C9:C9=R" + Trim(str(i)) + "C15))"
    
    i = i + 1
Loop
Cells(i, 16) = WorksheetFunction.Sum(Range(Cells(2, 16), Cells(i - 1, 16)))
Cells(i, 17) = WorksheetFunction.Sum(Range(Cells(2, 17), Cells(i - 1, 17)))
Debug.Print "耗费时间: " & Timer - sngStart
Cells(1, 14) = "管径"
Cells(1, 15) = "材质"
Cells(1, 16) = "长度  m"
Cells(1, 17) = "数量"
Cells(i, 15) = "合计："
End Sub

***利用宏表函数进行条件筛选的结果只能复制到工作表的区域内，无法利用变量接收。

        理解宏表函数的语法对于宏表函数中动态地址的处理很重要，现在解释一下统计宏表函数的含义：

 "=SUMPRODUCT((R2C8:R20000C8=R" + Trim(str(i)) + "C14)*(R2C9:R20000C9=R" + Trim(str(i)) + "C15),R2C12:R20000C12)"

        上面这句代码其实就是一段符合宏表函数语法的字符串，他等同于下面的字符串。

=SUMPRODUCT((R2C8:R20000C8=R2C14)*(R2C9:R20000C9=R2C15),R2C12:R20000C12)

        红色部份是一个查询条件，意思是：第8列的第二行到20000行=第14列第2行，也应是说（管径=“400”）

        绿色部份也是一个查询条件，意思是：第9列的第二行到20000行=第15列第2行，也应是说（管材=“塑料”）

        黄色部份是需要统计的区域，这时是统计符合条件的管线长度。

        统计数量时，不需要统计区域。

***查询条件还可以更多，每个查询条件用小括号括起来，两个条件中间用“*”相连接。

***查询条件中，把数值转化为字符串，一定要去除两端的空串，如Trim(str(i))，否则会出错。 

2.2数组法

        数组法是纯编程的方法，创建动态数组，筛选出唯一的统计条目，同时进行数据的统计，最后对结果进行排序，使统计结果按排序的要求顺序输出，本例是升序。代码如下：

Sub 综合数组分类统计()    '数组排序用时约 0.14 秒，内置函数排序用时约 0.031秒。
Dim i As Integer, j As Integer
Dim 总长 As Double, 数量 As Integer
Dim str(3)
Dim DataV(), js As Integer
On Error Resume Next
Sheets("Sheet1").Select
Dim sngStart As Single: sngStart = Timer
'筛选并排序：管径分类，材质分类
js = 0
i = 2
Do While Cells(i, 1) <> ""
    For j = 1 To js
        If Cells(i, 8) = DataV(0, j) And Cells(i, 9) = DataV(1, j) Then
            DataV(2, j) = DataV(2, j) + Cells(i, 12)
            DataV(3, j) = DataV(3, j) + 1
            GoTo 20
        End If
    Next
    js = js + 1
    ReDim Preserve DataV(3, js)
    DataV(0, js) = Cells(i, 8)
    DataV(1, js) = Cells(i, 9)
    DataV(2, js) = Cells(i, 12)
    DataV(3, js) = 1
20: i = i + 1
Loop

'数组排序
Dim m1 As String, m2 As String
For i = 1 To js
    For j = 1 To js - 1
        m1 = DataV(0, j) + "|" + DataV(1, j)
        m2 = DataV(0, j + 1) + "|" + DataV(1, j + 1)
        If m1 > m2 Then
           str(0) = DataV(0, j): DataV(0, j) = DataV(0, j + 1): DataV(0, j + 1) = str(0)
           str(1) = DataV(1, j): DataV(1, j) = DataV(1, j + 1): DataV(1, j + 1) = str(1)
           str(2) = DataV(2, j): DataV(2, j) = DataV(2, j + 1): DataV(2, j + 1) = str(2)
           str(3) = DataV(3, j): DataV(3, j) = DataV(3, j + 1): DataV(3, j + 1) = str(3)
        End If
    Next
Next
Range(Cells(1, 14), Cells(js + 1, 17)).Value = Application.Transpose(DataV)
Cells(js + 2, 16) = WorksheetFunction.Sum(Range(Cells(2, 16), Cells(i + 1, 16)))
Cells(i + 2, 17) = WorksheetFunction.Sum(Range(Cells(2, 17), Cells(i + 1, 17)))
Debug.Print "耗费时间: " & Format(Timer - sngStart, "0.0000000000")
Cells(1, 14) = "管径"
Cells(1, 15) = "材质"
Cells(1, 16) = "长度  m"
Cells(1, 17) = "数量"
Cells(i + 2, 15) = "合计："
End Sub

总结一下Filter函数多个筛选条件的使用。

Staff表所有数据如下：

1. 使用多个FILTER实现嵌套筛选

第一层筛选的是Department为“开发”的人员，第二层筛选Province是“广东省”的人员：

2. 在FILTER中使用AND和OR实现多条件筛选

效果跟上面是一样的，但是AND函数参数只能为2个。同时满足两个条件的才会被筛选出来

使用OR，只要满足Department为“开发”或者Province为“广东省”的数据即被筛选出来，

跟AND一样，OR参数也只能为2个。

3. 在FILTER中使用IN函数筛选数据

筛选出Department为开发、运维的人员。

组合使用：

2021-12-09 更新

可以直接使用"&&"串接查询条件：

FILTER(
	ALL('TestTable'),
	'TestTable'[Date] >= fDateFrom
	&&'TestTable'[Date] <= fDateTo
	&&'TestTable'[Week] = fWeek
	&&'TestTable'[Min] = fMin
	&&'TestTable'[Line] = fLine
	&&'TestTable'[Time] = rTime
	&&'TestTable'[Dir] = fDir
)

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