Insert Comment to last cell from another cell Excel - vba

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.
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
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