Cốp nhặt được 1 vài thứ về Comment, xin giới thiệu đến các bạn. (1 người xem)

[SA_DQ]

Chép các chú thích vô ô bên phải liền kề

[B]Sub CopyCommNextCell()[/B]
[COLOR="Blue"]'The following macro will copy comment text to the cell to the right, if that cell is empty.[/COLOR]
 Dim commRange As Range, myCell As Range
 Dim curWks As Worksheet
  Application.ScreenUpdating = False
  Set curWks = ActiveSheet:                 On Error Resume Next
  Set commRange = curWks.Cells.SpecialCells(xlCellTypeComments)
  On Error GoTo 0
  If commRange Is Nothing Then
     MsgBox "No comments found":             Exit Sub
  End If
  For Each myCell In commRange
     If myCell.Offset(0, 1).Value = "" Then
      	myCell.Offset(0, 1).Value = myCell.Comment.Text
     Else        
     End If
  Next myCell
  Application.ScreenUpdating = True
[B]End Sub[/B]

Tạo lời chú thích là value của cột bên trái liền kề

[B]Public Sub cReate_Comm()[/B]
    Dim Comm As Variant
    For Each Comm In ActiveSheet.Range("B1:B" & ActiveSheet.Range("B65535").End(xlUp).Row)
        Comm.NoteText Comm.Offset(0, -1).Value
    Next
[B]End Sub[/B]

Tạo lời chú thích tương ứng với giá trị tại ô trên nó hai ô

[B]Sub AddEditComment()[/B]
[COLOR="Blue"]'adds new plain text comment or positions cursor at end of existing comment text[/COLOR]On 
Error Resume Next
  Dim cMt As Comment:       Dim StrC As String
  
  StrC = Chr(ActiveCell.Offset(-2, 0).Value + 64)
  If IsNull(StrC) Then StrC = "Null"
  DeleteComment
  Set cMt = ActiveCell.Comment
  
  If cMt Is Nothing Then
    ActiveCell.AddComment Text:="" & Chr(10) & StrC
  End If
[COLOR="blue"]'  SendKeys "%ie~"[/COLOR]
  ActiveCell.Offset(1, 0).Select  
[B]End Sub

Sub DeleteComment()[/B]
    Selection.ClearComments
[B]End Sub[/b]

Tác động lên kích cỡ của comment mới tạo

[b]Sub AddComment()[/B]
    Dim objComment As Comment
                            On Error Resume Next
    Set objComment = AddCommentBox(Range("A2"), Range("A1").Value)
    If Err.Number <> 0 Then
        Set objComment = AddCommentBox(Range("A2"), Range("A1").Value)
    End If
    With objComment
        .Visible = False:                       .Text Text:="AutoSize"
        .Shape.TextFrame.AutoSize = True
    End With     
[B]End Sub

Function AddCommentBox(ToCell As Range, Text As String) As Comment[/B]
    Dim iJ As Double
                                On Error Resume Next
    Randomize:                  iJ = Rnd()
    If iJ < 0.5 Then
        Set AddCommentBox = ToCell.AddComment
        ToCell.Comment.Text Text & " 1"
    Else
        ToCell.Formula = "=" & Text & "  2 ":                     ToCell.AddComment
        ToCell.Comment.Text ToCell.Text:                        ToCell.Formula = ""
    End If
[B]End Function[/b]

Tạo 1 comment là file hình ( loại *.JPG) khi vùng dữ liệu cột B có trị rỗng

[b]Sub Add_Comments()[/B]   
 Dim curWks As Worksheet:    Dim myPict As String
    Dim myRng As Range, myCell As Range
     
    Set curWks = Sheets(1)
    myPict = "D:\Piture\Excel0.JPG"
    With curWks
        Set myRng = .Range("B2", .Cells(.Rows.Count, "B").End(xlUp))
    End With
    curWks.Columns("D").ClearComments
    For Each myCell In myRng.Cells
        If Trim(myCell.Value) = "" Then
            With myCell.Offset(0, 2)	 '2 columns to the right of B (D)
                .AddComment("").Shape.Fill.UserPicture (myPict)
            End With
        ElseIf Dir(CStr(myCell.Value)) = "" Then
            MsgBox myCell.Value & " Doesn't exist!"
        Else
            MsgBox "!"
        End If
    Next myCell
[B]End Sub[/b]

Tạo các Comment là files hình ảnh dạng “*.jpg”
Đoạn mã này sẽ tìm đến thư mục tại D:\Picture\ và copy toàn bộ các ảnh có trong nò. Sau đó đem tới Sheet hiện hành của excel và dán lên như là thành tố Comment của các ô bắt đầu từ A1

Public big_array() As String
[B]Sub InsertPicture()[/B]
    Dim i As Integer:   	Dim fSearch As Variant
    On Error Resume Next:		ActiveSheet.Cells.ClearComments
    On Error GoTo 0
 [COLOR="Blue"]    'load new pictures[/COLOR] 
   Set fSearch = Application.FileSearch
    With fSearch
        .NewSearch:	.LookIn = "D:\Picture"
        .Filename = "*.jpg"
        If .Execute = 0 Then
            MsgBox "There were no files found."
        Else
            ReDim big_array(.FoundFiles.Count - 1)
            For i = 1 To .FoundFiles.Count
                ActiveSheet.Cells(i, 1).AddComment.Text Text:=""
                ActiveSheet.Cells(i, 1).Comment.Shape.Fill.UserPicture (.FoundFiles(i))
            Next i
        End If
    End With
[B]End Sub[/B]

Ngày 19/05/08 bổ sung: http://giaiphapexcel.com/forum/showthread.php?t=10168

 

[SA_DQ]

Em cam on bac ve cai post nay. [COLOR="Purple"][B]http://www.giaiphapexcel.com/forum/s...&postcount=122[/B][/COLOR]
 Cho em hoi them ti xiu la neu bay gio em chua co comment nao ca va chua chon gi ca. 
Em muon la moi lan em add comment la tu dong no update gio va ngay
 vao ben trong cai comment day luon thi lam the nao?
 Cam on bac nhieu nhieu.

Sau đây là đoạn mã zúp cho bạn việc nhấp vô bất kì ô có chứa dữ liệu nào trong cột B (từ B2: B99) sẽ gán tự động 1 comment vô nó & nội dung là hàm NOW() mà bạn cần!
Bạn phải chép đoạn mã này vô phần Code của SheetName!

Option Explicit[b]
Private Sub Worksheet_SelectionChange(ByVal Target As Range)[/b]
 On Error GoTo LoiSChange
 Dim CommText:       Dim CommRng As Range, Rng As Range
 
 Application.ScreenUpdating = False
 If Not Intersect(Target, Range("B2:B99")) Is Nothing And Target.Value <> "" Then
    CommText = Str(Now())
    With Target
        .AddComment:                .Comment.Visible = False
        .Comment.Text Text:=CommText
        .Shape.TextFrame.AutoSize = True
    End With
 End If
ErrSChange:            Exit Sub
LoiSChange: Select Case Err
    Case Is <> 13
        Resume ErrSChange
    Case Else
        Resume Next
    End Select
[b]End Sub [/b]

Tham khảo thêm trong diễn đàn:
Chuyển giữ liệu từ sheet này thành ghi chú bên sheet khác:

http://giaiphapexcel.com/forum/showthread.php?p=78581#post78581​

Lọc dữ liệu tự động từ Insert Comment ...

http://www.giaiphapexcel.com/forum/showthread.php?t=10168​