Paste text into Excel comment VBA - excel

Question

I cannot find or create VBA code to allow pasting copied text from one cell in another sheet(sheet2) into a previously created comment in another sheet(sheet1).
Here is the code I have successfully compiled thus far, and I am stuck on how to get the text found into the comment box.
Sub For_Reals()
'Add Comment
Sheets("Sheet1").Range("F2").AddComment
Range("F2").Comment.Visible = False
'Find Value in Sheet2 based on Value from Sheet1
Dim FindString As String
Dim Rng As Range
FindString = Sheets("Sheet1").Range("F2").Value
If Trim(FindString) <> "" Then
With Sheets("Sheet2").Range("C:C")
Set Rng = .Find(What:=FindString, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
Application.Goto Rng, True
Else
MsgBox "Nothing found"
End If
End With
End If
'Copy Value 4 cells to the right of found Value
Selection.Offset(0, 4).Copy
'Need Code to paste copied value in previously created comment
End Sub

Answer 1

Rather than copy and paste the cell value into the comment, you create the text at the same time as creating the comment box. If a comment box already exists an error is raised - so remove any comment boxes in that cell beforehand.
The VBA help gives this as an example:
Worksheets(1).Range("E5").AddComment "Current Sales"
So with this in mind, this code will do the trick:
Sub For_Reals()
'Find Value in Sheet2 based on Value from Sheet1
Dim FindString As String
Dim Rng As Range
FindString = Sheets("Sheet1").Range("F2").Value
If Trim(FindString) <> "" Then
With Sheets("Sheet2").Range("C:C")
Set Rng = .Find(What:=FindString, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
'Remove any existing comments, create comment and add text.
If Not Rng Is Nothing Then
Sheets("Sheet1").Range("F2").ClearComments
Sheets("Sheet1").Range("F2").AddComment Rng.Offset(0, 4).Value
Range("F2").Comment.Visible = True
Else
MsgBox "Nothing found"
End If
End With
End If
End Sub

Answer 2

Final code I ended up with is below. Added a loop to run through the column, and added a second reference to pull both the definition and description into the comment. Thank you Darren Bartrup-Cook for helping me out when I was stuck!
Sub Add_Comment_As_Def_Desc_Reference()
'Posted by Jeff Barrett 2015-04-10
Dim FindString1 As String
Dim Rng1 As Range
Dim sCommentText1 As String
Dim sCommentText2 As String
Dim str1 As String
Dim str2 As String
Dim cmmt As String
Dim i As Integer
str1 = "Definition: "
str2 = "Description: "
'Loop Code, must specify range for i based on # of FieldAlias
Sheets("Fields").Select
Range("F4").Select
For i = 4 To 59
'Find Definition & Description in NASDefs based on Value from FieldAlias
FindString1 = ActiveCell.Value
If Trim(FindString1) <> "" Then
With Sheets("NASDefs").Range("C:C")
Set Rng1 = .Find(What:=FindString1, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
End With
End If
'Remove any existing comments, create comment and add text in FieldAlias
If Not Rng1 Is Nothing Then
ActiveCell.ClearComments
sCommentText1 = Rng1.Offset(0, 4).Value
sCommentText2 = Rng1.Offset(0, 5).Value
ActiveCell.AddComment.Text Text:=str1 & Chr(10) & Chr(10) & sCommentText1 & Chr(10) & Chr(10) & str2 & Chr(10) & Chr(10) & sCommentText2
ActiveCell.Comment.Visible = False
ActiveCell.Comment.Shape.AutoShapeType = msoShapeRoundedRectangle
'Format lines of text
With ActiveCell.Comment.Shape.TextFrame
.Characters.Font.ColorIndex = 5
End With
Else
MsgBox "Nothing found"
End If
'End Loop
ActiveCell.Offset(RowOffset:=1, ColumnOffset:=0).Select
Next i
'Resize Comment to fit text
'posted by Dana DeLouis 2000-09-16
Dim MyComments As Comment
Dim lArea As Long
For Each MyComments In ActiveSheet.Comments
With MyComments
.Shape.TextFrame.AutoSize = True
If .Shape.Width > 300 Then
lArea = .Shape.Width * .Shape.Height
.Shape.Width = 300
' An adjustment factor of 1.1 seems to work ok.
.Shape.Height = (lArea / 200) * 0.6
End If
End With
Next ' comment
End Sub