将文本粘贴到 Excel 评论 VBA

Question

我无法找到或创建 VBA 代码以允许将复制的文本从一个单元格粘贴到另一个 sheet(sheet2) 到另一个 [=17= 中先前创建的评论中](sheet1).

这是我到目前为止编译成功的代码，我一直在思考如何将找到的文本放入评论框中。

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

您无需将单元格值复制并粘贴到评论中，而是在创建评论框的同时创建文本。如果评论框已经存在，则会引发错误 - 因此请事先删除该单元格中的所有评论框。

VBA 帮助举例：

Worksheets(1).Range("E5").AddComment "Current Sales"

考虑到这一点，这段代码可以解决问题：

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

我最终得到的最终代码如下。通过该列向运行添加了一个循环，并添加了第二个引用以将定义和描述都拉入评论中。感谢 Darren Bartrup-Cook 在我遇到困难时帮助我！

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

将文本粘贴到 Excel 评论 VBA

Paste text into Excel comment VBA

excel

vba

paste