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
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
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
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.