本文于2023年8月19日首发于本人同名其他平台，更多文章案例请搜索关注！
内容提要
从总课表汇总出每名教师任教情况
相同内容单元格突出显示
大家好，我是冷水泡茶，今天在EXCELHOME论坛上看到一个求助贴：
他的总课表（Sheet1）是这样子的：
他的需求表（Sheet2）是这个样子的，把每位教师的任教班次课程连到一起，并统计任教课程数量：
我大概看了一下，觉得用字典应该可以解决，我们一起来看一看吧：
基本思路
1、把总课表数据读入数组。
2、从第2行，第2列开始循环数组，把教师姓名加入字典，同时连接对应行列的班次和课程名称，赋值给字典的item，每次都把前次的结果用“/”号连接起来。
3、然后把字典的keys写入目标表的A列，items写入C列。
4、循环目标工作表，计算“/”符号的数量，就是任教课程的数量，填入B列。
程序代码
1、Summary，统计汇总：
Sub Summary() Dim ws As Worksheet Dim lastRow As Long Dim lastCol As Long Dim arr(), Dic As Object Dim dKey As String Dim sortRange As Range Set ws = ThisWorkbook.Sheets("Sheet1") Set Dic = CreateObject("Scripting.Dictionary") lastRow = ws.UsedRange.Rows.Count lastCol = ws.UsedRange.Columns.Count ws.Activate arr = ws.Range(Cells(1, 1), Cells(lastRow, lastCol)).Value For i = 2 To lastRow For j = 2 To lastCol dKey = arr(i, j) If dKey <> "" Then Dic(dKey) = Dic(dKey) & arr(i, 1) & arr(1, j) & "/" End If Next Next Set ws = ThisWorkbook.Sheets("Sheet2") With ws .Activate lastRow = .UsedRange.Rows.Count lastCol = .UsedRange.Columns.Count .Range(Cells(2, 1), Cells(lastRow, lastCol)).ClearContents End With With ws .Range("A2").Resize(Dic.Count, 1).Value = Application.WorksheetFunction.Transpose(Dic.keys) .Range("c2").Resize(Dic.Count, 1).Value = Application.WorksheetFunction.Transpose(Dic.items) For i = 2 To Dic.Count + 1 .Cells(i, 2) = Len(.Cells(i, 3)) - Len(Replace(.Cells(i, 3), "/", "")) .Cells(i, 3) = Left(.Cells(i, 3), Len(.Cells(i, 3)) - 1) Next Set sortRange = .Range("A2:C" & Dic.Count + 1) With .Sort .SortFields.Clear '添加第一个排序字段（教师姓名） .SortFields.Add Key:=sortRange.Columns(1), Order:=xlAscending .SetRange sortRange .Header = xlNo ' 第一行不包含标题 .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With End WithEnd Sub
代码解析：
（1）定义一些变量、数组、字典。
（2）把ws设为源工作表“Sheet1”表。
（3）把数据装入arr数组。
（4）通过两层循环，从第2行、第2列开始，遍历数组的每一个元素。把每个不为空的元素装入字典Dic，同时把第一列、第一行与之对应的班次与课程连接起来，与字典的前值拼接，并通过“/“符号分隔。
（5）把ws设为目标工作表“Sheet2”表，激活ws。
（6）把ws工作表的数据区域清除内容。
（7）把字典Dic的keys写入ws表的A列，items写入C列。
（8）通过循环，计算C列单元格中有几个“/"符号，表示几门课程，写入B列，接着把C列单元格字符结尾的“/”去掉。
（9）由于字典是没有排序的，这里再对教师姓名进行排序，使用工作表的Sort方法。当然，也可以在写入之前，把字典Dic的keys、items写入到一个数组进行排序，并处理课程数量以及任课汇总字段。
2、其他过程：相同单元格突出显示，Worksheet_SelectionChange：
Private Sub Worksheet_SelectionChange(ByVal Target As Range) '将数据区域的单元格背景与字体颜色设置为默认 Dim dataRange As Range Dim rng As Range Set dataRange = ActiveSheet.UsedRange dataRange.Interior.Color = xlNone dataRange.Font.Color = RGB(0, 0, 0) '如果当前选择区域不在数据区域范围则退出此过程 If Application.Intersect(Target, dataRange) Is Nothing Then Exit Sub '如果当前选择的不止一个单元格，则将选取的第一个单元格作为目标单元格 If Target.Count > 1 Then Set Target = Target.Cells(1) '在数据区域内循环判断单元格内容是否与活动单元格一致，如果一致则设置黄色背景和红色字体 For Each rng In dataRange If rng.Value = Target.Value Then rng.Interior.Color = RGB(255, 255, 0) rng.Font.Color = RGB(255, 0, 0) End If NextEnd Sub
代码解析：
（1）这是原来楼主文件里的一个过程，把与选中单元格内容相同的单元格突出显示，他原来是限定了区域“B2:U30”，我把它改为当前已使用区域，增加代码的灵活性，复制到其他工作表应该不需要修改。
（2）dataRange，定义数据区域为Usedrange。
（3）循环dataRange，判断每一个单元格的值，如果等于当前选中的单元格，则把它们的背景色设置为RGB(255, 255, 0)、字体颜色设置为RGB(255, 0, 0)。
~~~~~~End~~~~~~
喜欢就点个赞、点在看、留个言呗！分享一下更给力！感谢！