Insert Comment to last cell from another cell Excel

Question

I have wrote a code in VBA Excel 2010 and it works great from sheet2 send data to sheet1 with a button submit. But I have a cell where after it will be submitted need to send this data to another sheet as a comment for the last cell. Ex:

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

Now on the same cell that is equal to k (LastRow, 3) I want to add comment from cell B9 from another sheet.

How can I add the B9 comment to this cell!

Thanks

Answer 1

First check that the cell your copying from has a comment using something like Not SourceCell.Comment Is Nothing .
If it has a comment then just set the Target cell value to text of the comment.

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  

Edit:

This will take the values from Sheet2 and place in comments on the last row holding data in 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