将注释插入另一个单元格Excel的最后一个单元格

Question

我在VBA Excel 2010中编写了一个代码，它可以很好地从sheet2发送数据到sheet1并提交按钮。 但我有一个单元格，在提交之后需要将此数据发送到另一个工作表作为最后一个单元格的注释。 E.x：

Dim ws1, ws2 As Worksheet
Set ws1 = ThisWorkbook.Sheets("Sheet1")
Set ws2 = ThisWorkbook.Sheets("Sheet2")
Set rngk = ws2.Range("B5")

com = ws2.Range("B9")
k = Application.WorksheetFunction.VLookup(rngk, ws2.Range("D5:E6").Value, 2, False)

lastRow = ws1.Range("A" & Rows.Count).End(xlUp).Row + 1
ws1.Cells(lastRow, 3) = k

现在在等于k（LastRow，3）的同一个单元格上，我想从另一个工作表中添加来自单元格B9的注释。

如何将B9注释添加到此单元格中？

由于

Answer 1

首先使用Not SourceCell.Comment Is Nothing之类的内容检查您复制的单元格是否有评论 如果它有注释，则只需将Target单元格值设置为注释文本。

Sub Test()

    Dim TargetCell As Range
    Dim SourceCell As Range


    Set TargetCell = ThisWorkbook.Worksheets("Sheet1").Range("H5")
    Set SourceCell = ThisWorkbook.Worksheets("Sheet2").Range("B9")

    If HasComment(SourceCell) Then
        TargetCell.Value = SourceCell.Comment.Text
    End If

End Sub

Public Function HasComment(Target As Range) As Boolean

    On Error GoTo ERROR_HANDLER

    If Target.Cells.Count = 1 Then
        With Target
            HasComment = Not .Comment Is Nothing
        End With
    Else
        Err.Raise vbObjectError + 513, "HasComment()", "Argument must reference single cell."
    End If

    On Error GoTo 0
    Exit Function

ERROR_HANDLER:
    Select Case Err.Number

        Case Else
            MsgBox "Error " & Err.Number & vbCr & _
                " " & Err.Description & " in procedure Module1.HasComment."
            Err.Clear
            Application.EnableEvents = True
    End Select

End Function  

编辑：

这将取Sheet2中的值并放在Sheet1中保存数据的最后一行的注释中：

Sub Test()

    Dim TargetColumns As Variant
    Dim SourceCells As Range
    Dim rCell As Range
    Dim rAddToCell As Range
    Dim x As Long

    TargetColumns = Array(6, 10, 15, 17) 'Column numbers to place into.
    Set SourceCells = ThisWorkbook.Worksheets("Sheet2").Range("B9,B15,B22,B26")

    'Look at each cell in turn.
    For Each rCell In SourceCells

        'Find the last cell in the correct column.
        Set rAddToCell = LastCell(ThisWorkbook.Worksheets("Sheet1"), CLng(TargetColumns(x)))

        'If there's already a comment then delete it first
        'Then add value from SourceCell into comment in Target column.
        With rAddToCell
            If HasComment(rAddToCell) Then
                .ClearComments
            End If
            .AddComment
            .Comment.Text Text:=rCell.Value
        End With

        x = x + 1
    Next rCell

End Sub

Public Function LastCell(wrkSht As Worksheet, Optional Col As Long = 0) As Range

    Dim lLastCol As Long, lLastRow As Long

    On Error Resume Next

    With wrkSht
        If Col = 0 Then
            lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
            lLastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
        Else
            lLastCol = Col '.Cells.Find("*", , , , xlByColumns, xlPrevious).Column
            lLastRow = .Columns(Col).Find("*", , , , xlByColumns, xlPrevious).Row
        End If

        If lLastCol = 0 Then lLastCol = 1
        If lLastRow = 0 Then lLastRow = 1

        Set LastCell = wrkSht.Cells(lLastRow, lLastCol)
    End With
    On Error GoTo 0

End Function

Public Function HasComment(Target As Range) As Boolean

    On Error GoTo ERROR_HANDLER

    If Target.Cells.Count = 1 Then
        With Target
            HasComment = Not .Comment Is Nothing
        End With
    Else
        Err.Raise vbObjectError + 513, "HasComment()", "Argument must reference single cell."
    End If

    On Error GoTo 0
    Exit Function

ERROR_HANDLER:
    Select Case Err.Number

        Case Else
            MsgBox "Error " & Err.Number & vbCr & _
                " " & Err.Description & " in procedure Module1.HasComment."
            Err.Clear
            Application.EnableEvents = True
    End Select

End Function