【代码】教师工作量统计：有点晕！我要这样做，四级嵌套字典，逐级拼接成一个字符串，设置单元格内指定文本的格式

Sub Workload1()    Dim ws As Worksheet, ws1 As Worksheet, ws2 As Worksheet    Dim lRow As Integer, lCol As Integer, rng As Range, cell As Range    Dim arr(), temp()    Dim dic1 As Object  '//科目数,教师：计数    Dim dic2 As Object  '//教师-年级-班级-科目：计数    Dim dic3 As Object  '//课时折算，科目：折算率    Dim dic4 As Object  '//科目    Dim teacher, grade, class, subject, i, j, item    Dim strDetail As String        Set ws1 = ThisWorkbook.Sheets("教师安排表")    Set ws2 = ThisWorkbook.Sheets("课时安排表")    Set dic1 = CreateObject("Scripting.Dictionary")    Set dic2 = CreateObject("Scripting.Dictionary")    Set dic3 = CreateObject("Scripting.Dictionary")    Set dic4 = CreateObject("Scripting.Dictionary")    arr = ws2.UsedRange.Value        '//所有科目装入字典dic4    For i = 3 To UBound(arr, 2)        subject = arr(1, i)        If subject <> "" Then            dic4(subject) = ""        End If    Next        '//处理课时折算系数，装入字典dic3,在后面统计总课时的时候调用    For i = 2 To UBound(arr) Step 2        grade = arr(i, 1)        For j = 3 To UBound(arr, 2)            subject = arr(1, j)            If subject <> "" Then                If arr(i, j) <> "" And arr(i, j) <> 0 Then                    If Not dic3.exists(grade) Then                        Set dic3(grade) = CreateObject("Scripting.Dictionary")                    End If                    If Not dic3(grade).exists(subject) Then                        Set dic3(grade)(subject) = CreateObject("Scripting.Dictionary")                    End If                    dic3(grade)(subject)("周课时量") = arr(i, j)                    dic3(grade)(subject)("折算的周课时量") = arr(i, j) * arr(i + 1, j)                End If            End If        Next    Next        '//处理教师安排表，    arr = ws1.UsedRange.Value    For i = 2 To UBound(arr)        grade = arr(i, 1)        class = arr(i, 2)        For j = 3 To UBound(arr, 2)            subject = arr(1, j)            teacher = arr(i, j)            If teacher <> "" Then                                '//教师任教科目统计                dic1(teacher) = dic1(teacher) + 1                                '//教师                If Not dic2.exists(teacher) Then                    Set dic2(teacher) = CreateObject("Scripting.Dictionary")                End If                                '//年级                If Not dic2(teacher).exists(grade) Then                    Set dic2(teacher)(grade) = CreateObject("Scripting.Dictionary")                End If                If Not dic2(teacher)(grade).exists(class) Then                    Set dic2(teacher)(grade)(class) = CreateObject("Scripting.Dictionary")                End If                If Not dic2(teacher)(grade)(class).exists(subject) Then                    ReDim temp(1)                    temp(0) = dic3(grade)(subject)("周课时量")                    temp(1) = dic3(grade)(subject)("折算的周课时量")                Else                    temp = dic2(teacher)(grade)(class)(subject)                    temp(0) = temp(0) + dic3(grade)(subject)("周课时量")                    temp(1) = temp(1) + dic3(grade)(subject)("折算的周课时量")                End If                dic2(teacher)(grade)(class)(subject) = temp            End If        Next    Next        lRow = dic2.Count + 1    lCol = 5    ReDim temp(1 To lRow, 1 To lCol)    temp(1, 1) = "教师姓名"    temp(1, 2) = "班级和科目数"    temp(1, 3) = "任教班级和科目明细"    temp(1, 4) = "周课时量"    temp(1, 5) = "折算的周课时量"        i = 1    For Each teacher In dic2.keys        i = i + 1        strDetail = ""        temp(i, 1) = teacher        temp(i, 2) = dic1(teacher)        For Each grade In dic2(teacher).keys            If strDetail = "" Then                strDetail = grade & "："            Else                strDetail = Left(strDetail, Len(strDetail) - 1)                strDetail = strDetail & Chr(10) & grade & "："            End If            j = 0            For Each class In dic2(teacher)(grade).keys                strDetail = strDetail & class & "班"                For Each subject In dic2(teacher)(grade)(class).keys                    item = dic2(teacher)(grade)(class)(subject)                    strDetail = strDetail & subject & item(0) & "节/"                    temp(i, 4) = temp(i, 4) + item(0)                    temp(i, 5) = temp(i, 5) + item(1)                Next            Next        Next        strDetail = Left(strDetail, Len(strDetail) - 1)        temp(i, 3) = strDetail    Next        Set ws = ThisWorkbook.Sheets("教师工作量")    With ws        .UsedRange.Clear        Set rng = .Cells(1, 1).Resize(lRow, lCol)        With rng            .HorizontalAlignment = xlCenter            .Columns(3).Offset(1).HorizontalAlignment = xlLeft            .Columns(3).WrapText = True            .VerticalAlignment = xlCenter            .Value = temp            .Borders.LineStyle = 1            Call formatCells(.Columns(3), dic4)        End With    End With    MsgBox "Done!"End Sub

Sub Workload2()    Dim ws As Worksheet, ws1 As Worksheet, ws2 As Worksheet    Dim lRow As Integer, lCol As Integer, rng As Range    Dim arr(), temp()    Dim dic1 As Object  '//科目数,教师：计数    Dim dic2 As Object  '//教师-年级-班级-科目：计数    Dim dic3 As Object  '//课时折算，科目：折算率    Dim dic4 As Object    Dim teacher, grade, class, subject, i, j, item    Dim strDetail As String        Set ws1 = ThisWorkbook.Sheets("教师安排表")    Set ws2 = ThisWorkbook.Sheets("课时安排表")    Set dic1 = CreateObject("Scripting.Dictionary")    Set dic2 = CreateObject("Scripting.Dictionary")    Set dic3 = CreateObject("Scripting.Dictionary")    Set dic4 = CreateObject("Scripting.Dictionary")        arr = ws2.UsedRange.Value    '//所有科目装入字典dic4    For i = 3 To UBound(arr, 2)        subject = arr(1, i)        If subject <> "" Then            dic4(subject) = ""        End If    Next        '//处理课时折算系数，装入字典dic3,在后面统计总课时的时候调用    For i = 2 To UBound(arr) Step 2        grade = arr(i, 1)        For j = 3 To UBound(arr, 2)            subject = arr(1, j)            If subject <> "" Then                If arr(i, j) <> "" And arr(i, j) <> 0 Then                    If Not dic3.exists(grade) Then                        Set dic3(grade) = CreateObject("Scripting.Dictionary")                    End If                    If Not dic3(grade).exists(subject) Then                        Set dic3(grade)(subject) = CreateObject("Scripting.Dictionary")                    End If                    dic3(grade)(subject)("周课时量") = arr(i, j)                    dic3(grade)(subject)("折算的周课时量") = arr(i, j) * arr(i + 1, j)                End If            End If        Next    Next        '//处理教师安排表，    arr = ws1.UsedRange.Value    For i = 2 To UBound(arr)        grade = arr(i, 1)        class = arr(i, 2)        For j = 3 To UBound(arr, 2)            subject = arr(1, j)            teacher = arr(i, j)            If teacher <> "" Then                                '//教师任教科目统计                dic1(teacher) = dic1(teacher) + 1                                '//教师                If Not dic2.exists(teacher) Then                    Set dic2(teacher) = CreateObject("Scripting.Dictionary")                End If                                '//年级                If Not dic2(teacher).exists(grade) Then                    Set dic2(teacher)(grade) = CreateObject("Scripting.Dictionary")                End If                If Not dic2(teacher)(grade).exists(subject) Then                    Set dic2(teacher)(grade)(subject) = CreateObject("Scripting.Dictionary")                End If                If Not dic2(teacher)(grade)(subject).exists(class) Then                    ReDim temp(1)                    temp(0) = dic3(grade)(subject)("周课时量")                    temp(1) = dic3(grade)(subject)("折算的周课时量")                Else                    temp = dic2(teacher)(grade)(subject)(class)                    temp(0) = temp(0) + dic3(grade)(subject)("周课时量")                    temp(1) = temp(1) + dic3(grade)(subject)("折算的周课时量")                End If                dic2(teacher)(grade)(subject)(class) = temp            End If        Next    Next        lRow = dic2.Count + 1    lCol = 5    ReDim temp(1 To lRow, 1 To lCol)    temp(1, 1) = "教师姓名"    temp(1, 2) = "班级和科目数"    temp(1, 3) = "任教班级和科目明细"    temp(1, 4) = "周课时量"    temp(1, 5) = "折算的周课时量"        i = 1    For Each teacher In dic2.keys        i = i + 1        strDetail = ""        temp(i, 1) = teacher        temp(i, 2) = dic1(teacher)        For Each grade In dic2(teacher).keys            If strDetail = "" Then                strDetail = grade & "："            Else                strDetail = Left(strDetail, Len(strDetail) - 1)                strDetail = strDetail & Chr(10) & grade & "："            End If            j = 0            For Each subject In dic2(teacher)(grade).keys                strDetail = strDetail & subject                For Each class In dic2(teacher)(grade)(subject).keys                    item = dic2(teacher)(grade)(subject)(class)                    strDetail = strDetail & class & "班" & item(0) & "节/"                    temp(i, 4) = temp(i, 4) + item(0)                    temp(i, 5) = temp(i, 5) + item(1)                Next            Next        Next        strDetail = Left(strDetail, Len(strDetail) - 1)        temp(i, 3) = strDetail    Next        Set ws = ThisWorkbook.Sheets("教师工作量")    With ws        .UsedRange.Clear        Set rng = .Cells(1, 1).Resize(lRow, lCol)        With rng            .HorizontalAlignment = xlCenter            .Columns(3).Offset(1).HorizontalAlignment = xlLeft            .Columns(3).WrapText = True            .VerticalAlignment = xlCenter            .Value = temp            .Borders.LineStyle = 1            Call formatCells(.Columns(3), dic4)        End With    End With    MsgBox "Done!"End Sub

Sub formatCells(rng As Range, dic As Object)    Dim cell As Range    Dim currPos As Integer, startPos As Integer    Dim key    For Each cell In rng.Cells        For Each key In dic.keys            startPos = 1            Do                currPos = InStr(startPos, cell.Value, key)                If currPos > 0 Then                    With cell.Characters(Start:=currPos, Length:=Len(key)).Font                        .Bold = True                        .Color = vbBlue                    End With                    startPos = currPos + Len(key)                End If            Loop While currPos > 0        Next    NextEnd Sub