【代码】多条件查询汇总，数组字典：学校教职工餐费补贴计算汇总

Option Explicit
Private Sub CmdQuery_Click()    Call myQueryEnd Sub
Private Sub CmdSum_Click()    Call mySumEnd Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)    Dim rngCategory As Range, rngMonth As Range, rngName As Range    Dim arr(), key1, key2, key3, key4    Dim tempDic As Object    If Target.CountLarge > 1 Then Exit Sub    Set rngCategory = Cells(1, 2)    Set rngMonth = Cells(2, 2)    Set rngName = Cells(3, 2)        If Target.Row <= 3 And Target.Column = 2 Then        Target.Validation.Delete    End If        Call getDic        If Target.Address = rngCategory.Address Then        '//类别        arr = dic.keys        Call SetDataValidation(arr, Target)    ElseIf Target.Address = rngMonth.Address Then        '//月份        Set tempDic = CreateObject("Scripting.Dictionary")        If rngCategory = "" Then            '//如果类别为空            For Each key1 In dic.keys                For Each key2 In dic(key1).keys                    tempDic(key2) = 1                Next            Next            arr = tempDic.keys            Call SetDataValidation(arr, Target)        Else            '//如果类别不为空            key1 = rngCategory.Value            If dic.exists(key1) Then                arr = dic(key1).keys                Call SetDataValidation(arr, Target)            End If                    End If    ElseIf Target.Address = rngName.Address Then        '//姓名        Set tempDic = CreateObject("Scripting.Dictionary")        If rngCategory = "" Then            '//类别为空            If rngMonth = "" Then                '//类别为空，月份为空                For Each key1 In dic.keys                    For Each key2 In dic(key1).keys                        For Each key3 In dic(key1)(key2).keys                            tempDic(key3) = 1                        Next                    Next                Next            Else                '//类别为空，月份不为空                key2 = CStr(rngMonth.Value)                                For Each key1 In dic.keys                    If dic(key1).exists(key2) Then                        For Each key3 In dic(key1)(key2).keys                            tempDic(key3) = 1                        Next                    End If                Next                            End If            arr = tempDic.keys            Call SetDataValidation(arr, Target)        Else            '//类别不为空                        key1 = rngCategory.Value            If rngMonth = "" Then                '//类别不为空,月份为空                If dic.exists(key1) Then                    For Each key2 In dic(key1).keys                        For Each key3 In dic(key1)(key2).keys                            tempDic(key3) = 1                        Next                    Next                End If            Else                '//类别不为空,月份也不为空                key2 = CStr(rngMonth.Value)                                If dic.exists(key1) Then                    If dic(key1).exists(key2) Then                        For Each key3 In dic(key1)(key2).keys                            tempDic(key3) = 1                        Next                    End If                End If                            End If                        arr = tempDic.keys            Call SetDataValidation(arr, Target)                    End If            End If    End Sub
Private Sub myQuery()    Dim rngCategory As Range, rngMonth As Range, rngName As Range    Dim rng As Range    Dim arr(), key1, key2, key3, key4    Dim tempDic As Object    Dim temp(), iRows As Integer, k As Integer, i As Integer    Dim bgColor As Double    Dim HasData As Boolean        On Error Resume Next    Set rngCategory = Cells(1, 2)    Set rngMonth = Cells(2, 2)    Set rngName = Cells(3, 2)    Call getDic    iRows = UBound(tbTitle)    ReDim temp(0 To iRows, 0 To 0)    For i = 0 To iRows        temp(i, 0) = tbTitle(i)    Next        If rngCategory = "" Then        '//类别为空        If rngMonth = "" Then            '//类别为空,月份为空            If rngName = "" Then                '//类别为空,月份为空,姓名为空                For Each key1 In dic.keys                    For Each key2 In dic(key1).keys                        For Each key3 In dic(key1)(key2).keys                            For Each key4 In dic(key1)(key2)(key3).items                                k = k + 1                                ReDim Preserve temp(0 To iRows, 0 To k)                                For i = 0 To iRows                                    temp(i, k) = key4(i, 0)                                Next                            Next                        Next                    Next                Next            Else                '//类别为空,月份为空,姓名不为空                key3 = rngName.Value                For Each key1 In dic.keys                    For Each key2 In dic(key1).keys                        If dic(key1)(key2).exists(key3) Then                            For Each key4 In dic(key1)(key2)(key3).items                                k = k + 1                                ReDim Preserve temp(0 To iRows, 0 To k)                                For i = 0 To iRows                                    temp(i, k) = key4(i, 0)                                Next                            Next                        End If                    Next                Next            End If        Else            '//类别为空,月份不为空            key2 = CStr(rngMonth.Value)                        If rngName = "" Then                '//类别为空,月份不为空,姓名为空                For Each key1 In dic.keys                    If dic(key1).exists(key2) Then                        For Each key3 In dic(key1)(key2).keys                            For Each key4 In dic(key1)(key2)(key3).items                                k = k + 1                                ReDim Preserve temp(0 To iRows, 0 To k)                                For i = 0 To iRows                                    temp(i, k) = key4(i, 0)                                Next                            Next                        Next                                            End If                Next            Else                '//类别为空,月份不为空,姓名不为空                key2 = CStr(rngMonth.Value)                key3 = rngName.Value                For Each key1 In dic.keys                    If dic(key1).exists(key2) Then                        If dic(key1)(key2).exists(key3) Then                            For Each key4 In dic(key1)(key2)(key3).items                                k = k + 1                                ReDim Preserve temp(0 To iRows, 0 To k)                                For i = 0 To iRows                                    temp(i, k) = key4(i, 0)                                Next                            Next                        End If                    End If                Next            End If        End If            Else        '//类别不为空        key1 = rngCategory        If rngMonth = "" Then            '//类别不为空,月份为空            If rngName = "" Then                '//类别为空,月份为空,姓名为空                If dic.exists(key1) Then                    For Each key2 In dic(key1).keys                        For Each key3 In dic(key1)(key2).keys                            For Each key4 In dic(key1)(key2)(key3).items                                k = k + 1                                ReDim Preserve temp(0 To iRows, 0 To k)                                For i = 0 To iRows                                    temp(i, k) = key4(i, 0)                                Next                            Next                        Next                    Next                End If            Else                '//类别不为空,月份为空,姓名不为空                key3 = rngName.Value                If dic.exists(key1) Then                    For Each key2 In dic(key1).keys                        If dic(key1)(key2).exists(key3) Then                            For Each key4 In dic(key1)(key2)(key3).items                                k = k + 1                                ReDim Preserve temp(0 To iRows, 0 To k)                                For i = 0 To iRows                                    temp(i, k) = key4(i, 0)                                Next                            Next                        End If                    Next                End If            End If        Else            '//类别为空,月份不为空            key2 = CStr(rngMonth.Value)                        If rngName = "" Then                '//类别为空,月份不为空,姓名为空                If dic.exists(key1) Then                    If dic(key1).exists(key2) Then                        For Each key3 In dic(key1)(key2).keys                            For Each key4 In dic(key1)(key2)(key3).items                                k = k + 1                                ReDim Preserve temp(0 To iRows, 0 To k)                                For i = 0 To iRows                                    temp(i, k) = key4(i, 0)                                Next                            Next                        Next                    End If                End If            Else                '//类别不为空,月份不为空,姓名不为空                key2 = CStr(rngMonth.Value)                key3 = rngName.Value                If dic.exists(key1) Then                    If dic(key1).exists(key2) Then                        If dic(key1)(key2).exists(key3) Then                            For Each key4 In dic(key1)(key2)(key3).items                                k = k + 1                                ReDim Preserve temp(0 To iRows, 0 To k)                                For i = 0 To iRows                                    temp(i, k) = key4(i, 0)                                Next                            Next                        End If                    End If                End If            End If        End If    End If            bgColor = RGB(127, 255, 212)        If UsedRange.Rows.Count > 5 Then        Range(Cells(5, 1), Cells(UsedRange.Rows.Count, UsedRange.Columns.Count)).Cells.Clear    End If    Set rng = Cells(5, 1).Resize(UBound(temp, 2) + 1, iRows + 1)    With rng        .Value = Application.Transpose(temp)        .Borders.LineStyle = 1        .Columns(4).NumberFormat = "yyyy-m-d"        .Cells(1, 5).Resize(.Rows.Count, 8).NumberFormat = "0.00"        .Rows(1).Interior.Color = bgColor        .Columns(Pxy(tbTitle, "餐费合计")).Interior.Color = bgColor        .Columns(Pxy(tbTitle, "补贴合计")).Interior.Color = bgColor            End With        Set rng = rng.Offset(1, 0)    With rng        With .Cells(.Rows.Count, 1).Resize(, 4)            .Merge            .HorizontalAlignment = xlCenter            .Value = "合计"        End With        .Cells(.Rows.Count, 5).Resize(, 8) = "=sum(" & .Columns(5).Resize(.Rows.Count - 1).Address(0, 0) & ")"        .Borders.LineStyle = 1        .Rows(.Rows.Count).Interior.Color = bgColor    End With    Columns.AutoFit    End Sub
Private Sub mySum()    Dim rngMonth As Range, rng As Range    Dim i As Integer, k As Integer    Dim key1, key2, key3, key4    Dim bgColor As Double    Set rngMonth = Cells(2, 2)    Dim dicCount As Object, dicAmount As Object    Dim arr1(), j As Integer    Dim iRows As Integer, iCols As Integer    Set dicCount = CreateObject("Scripting.Dictionary")    Set dicAmount = CreateObject("Scripting.Dictionary")    Call getDic        iRows = UBound(tbTitle)    ReDim temp(0 To iRows, 0 To 0)    For i = 0 To iRows        temp(i, 0) = tbTitle(i)    Next            If rngMonth = "" Then                For Each key1 In dic.keys            For Each key2 In dic(key1).keys                For Each key3 In dic(key1)(key2).keys                    For Each key4 In dic(key1)(key2)(key3).items                        k = k + 1                        ReDim Preserve temp(0 To iRows, 0 To k)                        For i = 0 To iRows                            temp(i, k) = key4(i, 0)                        Next                    Next                Next            Next        Next            Else        key2 = CStr(rngMonth.Value)        For Each key1 In dic.keys            If dic(key1).exists(key2) Then                For Each key3 In dic(key1)(key2).keys                    For Each key4 In dic(key1)(key2)(key3).items                        k = k + 1                        ReDim Preserve temp(0 To iRows, 0 To k)                        For i = 0 To iRows                            temp(i, k) = key4(i, 0)                        Next                    Next                Next            End If        Next            End If        ReDim arr(7)        For i = 1 To UBound(temp, 2)        key1 = temp(0, i)        key2 = temp(1, i)                If Not dicCount.exists(key1) Then            Set dicCount(key1) = CreateObject("Scripting.Dictionary")        End If        dicCount(key1)(key2) = 1                If Not dicAmount.exists(key1) Then            For j = 4 To 11                arr(j - 4) = temp(j, i)            Next            dicAmount(key1) = arr        Else            arr = dicAmount(key1)            For j = 4 To 11                arr(j - 4) = arr(j - 4) + temp(j, i)            Next            dicAmount(key1) = arr        End If    Next        iRows = dicCount.Count + 2    iCols = 10    ReDim arr1(1 To iRows, 1 To iCols)    arr1(1, 1) = "类别": arr1(1, 2) = "人数"    arr1(iRows, 1) = "合计"    For j = 4 To 11        arr1(1, j - 1) = tbTitle(j)    Next    k = 1        For Each key1 In dicCount.keys                k = k + 1        arr1(k, 1) = key1        arr1(k, 2) = dicCount(key1).Count        arr1(iRows, 2) = arr1(iRows, 2) + arr1(k, 2)        arr = dicAmount(key1)        For j = 0 To UBound(arr)            arr1(k, j + 3) = arr(j)                        arr1(iRows, j + 3) = arr1(iRows, j + 3) + arr(j)        Next    Next            bgColor = RGB(72, 201, 176)        If UsedRange.Rows.Count > 5 Then        Range(Cells(5, 1), Cells(UsedRange.Rows.Count, UsedRange.Columns.Count)).Cells.Clear    End If    Set rng = Cells(5, 1).Resize(UBound(arr1), UBound(arr1, 2))    With rng        .Value = arr1        .Borders.LineStyle = 1        .Cells(1, 3).Resize(.Rows.Count, 8).NumberFormat = "0.00"        .Rows(1).Interior.Color = bgColor        .Rows(1).HorizontalAlignment = xlCenter        .Columns(1).HorizontalAlignment = xlCenter        .Columns(2).HorizontalAlignment = xlCenter                .Columns(Pxy(arr1, "餐费合计", 2)).Interior.Color = bgColor        .Columns(Pxy(arr1, "补贴合计", 2)).Interior.Color = bgColor        .Rows(.Rows.Count).Interior.Color = bgColor                    End With    Columns.AutoFit    End Sub

Sub SetDataValidation(arr(), rng As Range)    '//设置单元格数据验证    Dim i As Integer, t As Integer    Dim listStr As String    Dim rngValue As String    rngValue = rng.Value    For i = LBound(arr) To UBound(arr)        listStr = listStr & arr(i) & ","        If rngValue = CStr(arr(i)) Then            t = 1        End If    Next    If t = 0 Then rng = ""    '//去掉结尾的 ","    listStr = Left(listStr, Len(listStr) - 1)    '//删除已有的数据验证    rng.Validation.Delete    With rng.Validation        '//添加数据验证，源为listStr        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _            Operator:=xlBetween, Formula1:=listStr        .IgnoreBlank = True        .InCellDropdown = True        .ShowInput = True        .ShowError = False  '//不显示出错警告，改为TRUE则显示，同时不能输入不合验证的字符    End WithEnd Sub

Public dic As Object, tbTitle()
Sub getDic()    Dim i As Long, k As Long    Dim category, currDate As Date, currMonth, teacher, currSubsidy As Double, lastSubsidy As Double    Dim currDay As String    Dim arr(), temp(), subsidies(), iRows As Integer    Dim ws As Worksheet, lastRow As Long, lastCol As Long    Dim mealType As String, actualAmount As Double    Set dic = CreateObject("Scripting.Dictionary")    Set ws = ThisWorkbook.Sheets("消费明细")    With ws        '//取消筛选        If .AutoFilterMode Then            If .FilterMode Then                .ShowAllData            End If        End If        lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row        lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column        arr = .Range(.Cells(1, 1), .Cells(lastRow, lastCol)).Value    End With    tbTitle = Array("类别", "姓名", "部门名称", "消费日期", "早餐", "午餐", "晚餐", "餐费合计", "早餐补贴", "午餐补贴", "晚餐补贴", "补贴合计")    iRows = UBound(tbTitle)    subsidies = Array(5, 14, 10)    For i = 2 To lastRow        If arr(i, 1) <> "" Then            category = arr(i, Pxy(arr, "类别", 2))            currDate = CDate(arr(i, Pxy(arr, "消费时间", 2)))            currDay = Format(currDate, "yyyy-mm-dd")            currMonth = Format(currDate, "yyyymm")            teacher = arr(i, Pxy(arr, "姓名", 2))            mealType = getMealType(currDate)            actualAmount = arr(i, Pxy(arr, "消费金额", 2))            If Not dic.exists(category) Then                Set dic(category) = CreateObject("Scripting.Dictionary")            End If                        If Not dic(category).exists(currMonth) Then                Set dic(category)(currMonth) = CreateObject("Scripting.Dictionary")            End If                        If Not dic(category)(currMonth).exists(teacher) Then                Set dic(category)(currMonth)(teacher) = CreateObject("Scripting.Dictionary")                            End If            If Not dic(category)(currMonth)(teacher).exists(currDay) Then                ReDim temp(0 To iRows, 0 To 0)                temp(Pxy(tbTitle, "类别") - 1, k) = category                temp(Pxy(tbTitle, "姓名") - 1, k) = teacher                temp(Pxy(tbTitle, "部门名称") - 1, k) = arr(i, Pxy(arr, "部门名称", 2))                temp(Pxy(tbTitle, "消费日期") - 1, k) = currDay                            Else                temp = dic(category)(currMonth)(teacher)(currDay)            End If            temp(Pxy(tbTitle, mealType & "餐") - 1, k) = temp(Pxy(tbTitle, mealType & "餐") - 1, k) + actualAmount                        temp(Pxy(tbTitle, "餐费合计") - 1, k) = temp(Pxy(tbTitle, "餐费合计") - 1, k) + actualAmount                        actualAmount = temp(Pxy(tbTitle, mealType & "餐") - 1, k)            currSubsidy = calculateSubsidy(mealType, subsidies(), actualAmount)                        lastSubsidy = temp(Pxy(tbTitle, mealType & "餐补贴") - 1, k)            temp(Pxy(tbTitle, mealType & "餐补贴") - 1, k) = currSubsidy            temp(Pxy(tbTitle, "补贴合计") - 1, k) = temp(Pxy(tbTitle, "补贴合计") - 1, k) - lastSubsidy + currSubsidy                        dic(category)(currMonth)(teacher)(currDay) = temp        End If    NextEnd Sub

Function getMealType(currDate As Date) As String        '判断时间并返回早、中、晚的字符串    Select Case True    Case TimeValue(currDate) >= TimeValue("06:30") And TimeValue(currDate) <= TimeValue("09:00")        getMealType = "早"    Case TimeValue(currDate) >= TimeValue("11:00") And TimeValue(currDate) <= TimeValue("13:00")        getMealType = "午"    Case TimeValue(currDate) >= TimeValue("17:00") And TimeValue(currDate) <= TimeValue("19:30")        getMealType = "晚"    Case Else        '//时间段划分不连续，时间段外的怎么处理？        '//如果是按下面规则，整个函数就用这个判断就可以了。        '//如果不在时间段不统计，那么 getMealType = "其他"或者什么值，在统计的时候剔除，也可以在统计表中加一列。        If TimeValue(currDate) <= TimeValue("10:30") Then            getMealType = "早"        ElseIf TimeValue(currDate) <= TimeValue("15:30") Then            getMealType = "午"        Else            getMealType = "晚"        End If    End Select    End Function
Function calculateSubsidy(mealType As String, subsidies(), actualAmount As Double) As Double
    Dim subsidy As Double        ' 根据“早”、“午”、“晚”计算补贴    Select Case mealType        Case "早"            If actualAmount >= subsidies(0) Then                subsidy = subsidies(0)            Else                subsidy = actualAmount            End If        Case "午"            If actualAmount >= subsidies(1) Then                subsidy = subsidies(1)            Else                subsidy = actualAmount            End If        Case "晚"            If actualAmount >= subsidies(2) Then                subsidy = subsidies(2)            Else                subsidy = actualAmount            End If        Case Else            subsidy = 0    End Select        ' 返回补贴金额    calculateSubsidy = subsidy
End Function
Sub checkDic()    If dic Is Nothing Then        Call getDic    ElseIf dic.Count = 0 Then        Call getDic    End IfEnd Sub
Function Pxy(arr(), FieldName As String, Optional arrType As Integer = 0)    '**********************************    '//参数说明：    '//arr(),数组，可以是一维也可以是二维    '//FieldName，字段名，需要定位的字段名    '//arrType=0,表示一维数组    '//arrType=1,表示二维数组，查找第一列    '//arrType=2,表示二维数组，查找第一行    '**********************************    Dim k As Long, i As Long, t As Integer    k = 0: t = 0    Select Case arrType    Case Is = 0        '//一维数组，循环数组，查找字段值,取得其位置k        '//如果找到，则令t=1,退出循环        For i = LBound(arr) To UBound(arr)            k = k + 1            If arr(i) = FieldName Then                t = 1                Exit For            End If        Next    Case Is = 1        '//二维数组，循环数组，在第一列查找字段值,取得其位置k        '//如果找到，则令t=1,退出循环        For i = LBound(arr, 1) To UBound(arr, 1)            k = k + 1            If arr(i, 1) = FieldName Then                t = 1                Exit For            End If        Next    Case Is = 2        '//二维数组，循环数组，在第一行查找字段值,取得其位置k        '//如果找到，则令t=1,退出循环        For i = LBound(arr, 2) To UBound(arr, 2)            k = k + 1            If arr(1, i) = FieldName Then                t = 1                Exit For            End If        Next    End Select    '//如果t=1,表示找到了字段的值，函数的值等于k    '//否则，表示没找到字段的值，函数的值等0    If t = 1 Then        Pxy = k    Else        Pxy = 0    End IfEnd Function