將文本粘貼到Excel中評VBA

Question

我無法找到或創建VBA代碼，允許從一個細胞中的另一個工作表（Sheet2中）到另一個工作表（工作表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