以下代码可实现：

将当前工作表中的所有注释内容复制到新工作表的单元格中，复制后的内容在同一列由上向下排列

Attribute VB_Name = "当前工作表内所有注释复制到新工作表"
Sub CopyCellCommentsToNewSheet()
    Dim wsSource As Worksheet
    Dim wsTarget As Worksheet
    Dim i As Long
    Dim r As Range
    Dim lastRow As Long

    ' 设置源工作表为当前活动工作表
    Set wsSource = ActiveSheet

    ' 创建新工作表并设置为目标工作表
    Set wsTarget = Sheets.Add(After:=Sheets(Sheets.Count))
    wsTarget.Name = "Comments"

    ' 遍历源工作表中的所有单元格
    i = 1
    For Each r In wsSource.UsedRange
        If Not r.comment Is Nothing Then
            ' 如果单元格有注释，将其内容复制到新工作表的A列
            wsTarget.Cells(i, 1).Value = r.comment.Text
            ' 更新i以指向新行
            i = i + 1
        End If
    Next r

    ' 计算新工作表中最后一个非空单元格的行号
    lastRow = wsTarget.Cells(wsTarget.Rows.Count, 1).End(xlUp).Row

    ' 可选：自动调整列宽以适应内容
    wsTarget.Columns("A").AutoFit

    ' 可选：清除新工作表中的空白单元格
    If lastRow < wsTarget.Rows.Count Then
        wsTarget.Range(wsTarget.Cells(lastRow + 1, 1), wsTarget.Cells(wsTarget.Rows.Count, 1)).ClearContents
    End If

    ' 可选：提示用户完成操作
    MsgBox "所有注释已成功复制到新工作表。", vbInformation, "完成"
End Sub

线程式批注和注释之间的区别 – Microsoft 支持