Excel VBA实现跨工作表汇总学生数据及线程型批注

我需要将一个工作表中的横向数据在另一个工作表中纵向汇总：第一个工作表纵向记录学生姓名，对应数据为横向排列；第二个工作表是仅展示单个学生数据的临时报表。

期望功能 #

• 点击A列偶数单元格时生成对应学生的数据报表
• 每个学生的数据占用两行：点击的偶数行及其下一行的奇数行
• 遍历这两行的单元格区域，将数据导入临时工作表
• 学生姓名放在B列，数据从E列开始向右扩展
• 多数数据单元格带有线程型批注，需将批注内容纵向放入单元格

现有问题 #

编写的VBA代码可插入临时工作表并添加表头（Number, Author, Date, Text），但无法传输单元格数据及线程型批注。代码如下：

Sub ListCommentsThreaded()
    Application.ScreenUpdating = False
    
    Dim wb As Workbook
    Dim myCmt As CommentThreaded
    Dim curwks As Worksheet
    Dim newwks As Worksheet
    Dim currng As Range
    Dim cell As Range
    Dim i As Long
    Dim cmtCount As Long
    
    Set wb = ThisWorkbook
    Set curwks = ActiveSheet
    
    'THE CURRENT RANGE WILL BE A SET OF TWO ROWS, STARTING IN COL B
    'THE RANGE LENGTH (# COLUMNS) WILL VARY PER STUDENT, ARBITRARILY SET AT 90 COLS
    'MANY OF THE CELLS IN THE RANGE WILL HAVE THREADED COMMENTS, STARTING IN COLUMN E
    'SOME CELLS MAY LACK COMMENTS
    
    'Set currng = curwks.Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(1, 90))
    Set currng = curwks.Range(ActiveCell.Resize(1, 90).Address)
    
    Set newwks = wb.Worksheets.Add
    
    newwks.Range("B5:E5").Value = Array("Number", "Author", "Date", "Text")
          
    curwks.Activate
    i = 0
    For Each cell In currng.Cells
        If Not IsNumeric(cell.Value) Then
            With cell
                If Not .CommentThreaded Is Nothing Then
                    With newwks
                        i = i + 1
                        On Error Resume Next
                        .Cells(i, 1).Value = i - 1
                        .Cells(i, 2).Value = myCmt.Author.Name
                        .Cells(i, 3).Value = myCmt.Date
                        .Cells(i, 4).Value = myCmt.Text
                    End With
                End If
            End With
        End If
    Next cell
    
    With newwks
        .Columns(4).ColumnWidth = 50
        .Columns.AutoFit
        With .Cells
            .EntireRow.AutoFit
            .VerticalAlignment = xlTop
            .WrapText = True
        End With
    End With
    
    Application.ScreenUpdating = True
    
End Sub

代码修正说明及修正后代码 #

原代码存在4个核心问题：未选中学生的两行数据、未定义myCmt引用导致空错误、错误过滤数值型数据、未处理学生姓名和数据放置逻辑。以下是修正后的代码：

Sub GenerateStudentReport()
    Application.ScreenUpdating = False
    
    Dim wb As Workbook
    Dim curwks As Worksheet
    Dim newwks As Worksheet
    Dim studentRange As Range
    Dim cell As Range
    Dim rowNum As Long
    Dim colOffset As Integer
    Dim studentName As String
    Dim cmt As CommentThreaded
    
    Set wb = ThisWorkbook
    Set curwks = ActiveSheet
    
    ' 校验操作合法性：仅允许点击A列偶数行
    If ActiveCell.Column <> 1 Or ActiveCell.Row Mod 2 <> 0 Then
        MsgBox "请点击A列的偶数单元格！", vbExclamation
        Application.ScreenUpdating = True
        Exit Sub
    End If
    
    ' 获取学生的两行数据：偶数行+下一行奇数行，从B列开始取90列
    Set studentRange = curwks.Range(ActiveCell.Offset(0, 1), ActiveCell.Offset(1, 90))
    studentName = ActiveCell.Value ' 提取当前学生姓名
    
    ' 创建临时工作表并初始化表头
    Set newwks = wb.Worksheets.Add
    With newwks
        .Range("B2").Value = "学生姓名"
        .Range("C2").Value = studentName
        .Range("B4").Value = "单元格数据"
        .Range("B5:E5").Value = Array("序号", "批注作者", "批注日期", "批注内容")
    End With
    
    rowNum = 6 ' 批注内容从第6行开始写入
    colOffset = 0 ' 记录数据列的偏移量
    
    ' 遍历学生两行的所有单元格
    For Each cell In studentRange.Cells
        colOffset = colOffset + 1
        ' 将原单元格数据写入临时表E列开始的对应位置
        newwks.Cells(4, 4 + colOffset).Value = cell.Value
        
        ' 处理线程型批注（包含主批注和回复）
        If Not cell.CommentThreaded Is Nothing Then
            ' 先写入主批注
            newwks.Cells(rowNum, 2).Value = rowNum - 5
            newwks.Cells(rowNum, 3).Value = cell.CommentThreaded.Author.Name
            newwks.Cells(rowNum, 4).Value = cell.CommentThreaded.Date
            newwks.Cells(rowNum, 5).Value = cell.CommentThreaded.Text
            rowNum = rowNum + 1
            
            ' 写入所有批注回复
            For Each cmt In cell.CommentThreaded.Replies
                newwks.Cells(rowNum, 2).Value = rowNum - 5
                newwks.Cells(rowNum, 3).Value = cmt.Author.Name
                newwks.Cells(rowNum, 4).Value = cmt.Date
                newwks.Cells(rowNum, 5).Value = cmt.Text
                rowNum = rowNum + 1
            Next cmt
        End If
    Next cell
    
    ' 格式化临时工作表
    With newwks
        .Columns("E:E").ColumnWidth = 50
        .Columns.AutoFit
        .Cells.VerticalAlignment = xlTop
        .Cells.WrapText = True
        ' 冻结表头，方便浏览
        .Rows("6:6").Select
        ActiveWindow.FreezePanes = True
    End With
    
    Application.ScreenUpdating = True
    MsgBox "学生报表已生成！", vbInformation
End Sub

关键修正点 #

1. 操作合法性校验：避免用户误点击无效单元格
2. 正确选取数据范围：包含学生的两行数据，符合需求
3. 修复批注引用错误：正确遍历线程型批注的主内容和所有回复
4. 完整传输数据：同步原单元格数据到临时表对应位置
5. 优化报表体验：添加学生姓名展示、冻结表头、自动适配格式

内容的提问来源于stack exchange，提问作者middleschoolteacher