Option Explicit '-- remove lines above Options Explicit from Exported copy --- '-- David McRitchie Aug 10, 2002 (if date updated) '-- http://www.mvps.org/dmcritchie/excel/ccomment.htm '-- http://www.mvps.org/dmcritchie/excel/ccommentx.htm '-- http://www.mvps.org/dmcritchie/excel/code/ccomment.txt Sub FormulasIntoComments() Dim cell As Range Selection.ClearComments For Each cell In Selection If cell.HasFormula Then cell.AddComment cell.Formula cell.Comment.Visible = False cell.Comment.Shape.TextFrame.AutoSize = True End If Next cell End Sub Sub TextIntoComments() Dim cell As Range Selection.ClearComments For Each cell In Selection If Trim(cell.Text) <> "" Then cell.AddComment cell.Text cell.Comment.Visible = False cell.Comment.Shape.TextFrame.AutoSize = True End If Next cell End Sub ' Function MyComment(rng As Range) ' Application.Volatile 'see webpage to bypass volatile ' Dim str As String ' str = Trim(rng.Comment.Text) ' '// If you want to remove Chr(10) character from string, then ' str = Application.Substitute(str, vbLf, " ") ' MyComment = str ' End Function Function HasComment(Target As Range) As Boolean 'Patrick Molloy, 2001-11-17 programming On Error Resume Next ' to use in WS: =HasComment(a1) Dim txt As String ' to use in VBA: MsgBox hascomment(Range("a1")) txt = Target.Comment.Text 'in Event: MsgBox hascomment(Target) HasComment = Err.number = 0 Err.Clear End Function Sub writeComments() ' Nick Hodge -- 1999-11-13 in MISC, prints cell comments out to a ' text file, with their address. ' http://groups.google.com/groups?oi=djq&ic=1&selm=an_548083890 ' modified 1999-12-29 D.McRitchie to include cell to left of comment, ' and browse result Dim MyComment As Comment, filename As String Dim mySht As Worksheet Dim IEpath As String, Netscapepath As String filename = "C:\temp\ccomment.txt" Open filename For Output As #1 Print #1, FormatDateTime(Date, vbLongDate) For Each mySht In Worksheets For Each MyComment In Worksheets(mySht.Name).Comments Print #1, " " Print #1, MyComment.Parent.Parent.Name & "!" _ & MyComment.Parent.Address(0, 0) _ & " comment: " & Trim(MyComment.Text) If MyComment.Parent.Column > 1 Then _ Print #1, " cell " & MyComment.Parent.Offset(0, -1). _ Address(0, 0) & " on left has value: " _ & MyComment.Parent.Offset(0, -1).Value Print #1, " cell " & MyComment.Parent.Address(0, 0) & _ " has value: " & MyComment.Parent.Value Next MyComment Next mySht Close #1 Netscapepath = _ "H:\program files\netscape\Communicator\program\netscape.exe" IEpath = "C:\program files\internet explorer\iexplore.exe" Shell IEpath & " " & filename, vbNormalFocus 'Shell Netscapepath & " " & filename, vbNormalFocus 'Shell "Notepad " & filename, vbNormalFocus End Sub Sub AddComments() 'Posted by Dave Ramage, 2001-04-11, misc, Dim rngComments, rngCells As Range Dim lCnt As Long 'get user to select range Set rngComments = Application.InputBox(Prompt:="Select" _ & "range containing comments text:", _ Title:="Add comments: Step 1 of 2", Type:=8) 'was Cancel pressed? If rngComments Is Nothing Then Exit Sub Set rngCells = Application.InputBox(Prompt:="Select cells to update:", _ Title:="Add comments: Step 2 of 2", _ Type:=8) If rngCells Is Nothing Then Exit Sub 'are ranges the same size? If rngCells.Areas(1).Cells.Count <> rngComments.Areas(1).Cells.Count Then MsgBox ("Ranges must be the same size!") Exit Sub End If 'add comments For lCnt = 1 To rngCells.Areas(1).Cells.Count 'does the cell already have a comment? If rngCells.Areas(1).Cells(lCnt).Comment Is Nothing Then 'no comment, so add one rngCells.Areas(1).Cells(lCnt).AddComment _ rngComments.Areas(1).Cells(lCnt).Text Else 'already comment, so delete then add rngCells.Areas(1).Cells(lCnt).Comment.Delete rngCells.Areas(1).Cells(lCnt).AddComment _ rngComments.Areas(1).Cells(lCnt).Text End If Next lCnt End Sub Sub CommentTestGenerator() ' http://www.mvps.org/dmcritchie/code/ccomments 2002-08-10 'The range generated to too big to store as if ' RANGE("A1,B2,C3,...,IV256,IU255,IT254,...,B2,A1") ' so the named range using this range would be incomplete ' have reduced to making a range that can be used. Dim i As Long, rStr As String, runCol As Long Dim r As Long, k As Long Range("E11:F13").Select MarkCells '-- found in join.htm#markcells TextIntoComments Range("b11").Value = "B12:B14" Range("b11").Font.Bold = True Range("b12").Value = 1251.15 Range("B12").NumberFormat = "$#,###.00" Range("B13") = Date Range("B14") = Time Range("B11:B14").Select TextIntoComments rStr = "" runCol = 12 For i = 1 To runCol 'instead of 2 to 256 If i <> 1 And i <> 3 And i <> 7 And i <> 7 And i <> 8 And i <> 9 Then rStr = rStr & "," & Cells(i, i).Address(0, 0) Cells(i, i).Value = "text " & Cells(i, i).Address(0, 0) Cells(i, i).ClearComments Cells(i, i).AddComment "Comment for " & Cells(i, i).Address(0, 0) End If Next i '-- excel does not permit For i=2, i=4 to 6, I=10 to runCol For k = 1 To runCol - 1 r = runCol + k i = runCol - k If i <> 1 And i <> 3 And i <> 7 And i <> 7 And i <> 8 And i <> 9 Then rStr = rStr & "," & Cells(r, i).Address(0, 0) Cells(r, i).Value = "text " & Cells(r, i).Address(0, 0) Cells(r, i).ClearComments Cells(r, i).AddComment "Comment for " & Cells(r, i).Address(0, 0) End If Next k rStr = Mid(rStr, 2) 'remove leading comma MsgBox Right(rStr, 20) & " length=" & Len(rStr) Range(rStr).Select Selection.Interior.ColorIndex = 33 printcommentsbycolumn End Sub Sub printcommentsbycolumn() 'David McRitchie, misc, 2002-08-09, 'reference: http://www.mvps.org/dmcritchie/excel/ccomments.htm Dim cell As Range Dim myRange As Range, myrangeC As Range Dim col As Long Dim RowOS As Long Dim wsSource As Worksheet Dim wsNew As Worksheet If ActiveSheet.Comments.Count = 0 Then MsgBox "No comments in entire sheet" Exit Sub End If Application.ScreenUpdating = False Application.Calculation = xlCalculationManual 'xl95 uses xlManual Set wsSource = ActiveSheet Sheets.Add Set wsNew = ActiveSheet wsSource.Activate With wsNew.Columns("A:C") .VerticalAlignment = xlTop .WrapText = True End With wsNew.Columns("B").ColumnWidth = 15 wsNew.Columns("C").ColumnWidth = 60 wsNew.PageSetup.PrintGridlines = True RowOS = 2 wsNew.Cells(1, 3) = "'" & Application.ActiveWorkbook.FullName & " -- " & _ Application.ActiveSheet.Name For col = 1 To ActiveSheet.UsedRange.Columns.Count 'On Error GoTo nxtCol Set myrangeC = Intersect(ActiveSheet.UsedRange, Columns(col), _ Cells.SpecialCells(xlCellTypeComments)) If myrangeC Is Nothing Then GoTo nxtCol For Each cell In myrangeC If Trim(cell.Comment.Text) <> "" Then RowOS = RowOS + 1 wsNew.Cells(RowOS, 1) = "'" & cell.Address(0, 0) & ":" wsNew.Cells(RowOS, 2) = "'" & cell.Text wsNew.Cells(RowOS, 3) = "'" & cell.Comment.Text End If Next cell nxtCol: Next col wsNew.Activate Application.Calculation = xlCalculationAutomatic 'xl95 uses xlAutomatic Application.ScreenUpdating = True End Sub Sub ListComms() ' Dick Kusleika, 2002-11-13, excel.misc Dim cell As Range Dim sh As Worksheet Dim csh As Worksheet Set csh = ActiveWorkbook.Worksheets.Add csh.Name = "Comments" For Each sh In ActiveWorkbook.Worksheets If sh.Name <> csh.Name Then If Not sh.Cells.SpecialCells(xlCellTypeComments) Is Nothing Then For Each cell In sh.Cells.SpecialCells(xlCellTypeComments) If Not cell.Comment Is Nothing Then With csh.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) .Value = sh.Name & " " & cell.Address .Offset(0, 1).Value = cell.Comment.Text End With End If Next cell End If End If Next sh End Sub Sub CommentPopulateSelection() Dim cell As Range 'DMcRitchie, programming, 2003-10-05 Selection.ClearComments If Trim(ActiveCell.Text) <> "" Then For Each cell In Selection cell.AddComment ActiveCell.Text Next cell End If End Sub Sub CommentPopulateText() Dim cell As Range 'based on DMcRitchie, programming, 2003-10-05 Selection.ClearComments If Trim(ActiveCell.Text) <> "" Then For Each cell In Selection cell.AddComment cell.Text Next cell End If End Sub Sub CommentRemoveUserName() Dim cmt As Comment 'DMcRitchie, misc, 2004-04-01 Dim LUSR As Long Dim USR As String USR = LCase(Application.UserName) & ":" & Chr(10) LUSR = Len(USR) For Each cmt In ActiveSheet.Comments If Left(LCase(cmt.Text), LUSR) = USR Then cmt.Text Mid(cmt.Text, LUSR + 1) End If Next End Sub Sub FitComments() Dim c As Comment 'David McRitchie, excel.setup, 2001-11-15 For Each c In ActiveSheet.Comments c.Shape.TextFrame.AutoSize = True Next c End Sub Sub FitComments2() Dim c As Comment For Each c In ActiveSheet.Comments Dim myStr As String, myaddrs As String, myaddr As Range myStr = c.Text myaddrs = c.Parent.Address(1, 1) Range(myaddrs).Interior.Color = 4 MsgBox myStr & "--" & myaddrs MsgBox c.Parent.Address(1, 1) myStr = Replace(myStr, Chr(10), " ") myStr = Replace(myStr, Chr(13), " ") On Error Resume Next c.Comment.Delete On Error GoTo 0 Range(myaddrs).AddComment myStr c.Shape.TextFrame.AutoSize = True Next c End Sub Sub MakeComment() On Error Resume Next ActiveCell.Offset(0, 1).Comment.Delete On Error GoTo 0 Dim myStr As String myStr = "mystr characters" ActiveCell.Offset(0, 1).AddComment "David McRitchie 123" _ & Chr(10) & myStr _ & Chr(10) & "a " & ActiveCell.Offset(0, 1).Address(1, 1) _ & "b" & Chr(10) & "c" & Chr(10) & "d" & Chr(10) & "End" End Sub Sub FillComments() Dim cell As Range Selection.ClearComments For Each cell In Selection cell.AddComment cell.Text cell.Comment.Visible = False cell.Comment.Shape.TextFrame.AutoSize = True Next cell End Sub Sub CommentsSelectAll() On Error Resume Next 'D.McRitchie, 2004-06-05 Cells.SpecialCells(xlCellTypeComments).Select If Err.number <> 0 Then MsgBox "SelectAllComments" & Chr(10) & Err.number & " " & Err.Description End If End Sub Sub SelectAllValidations() On Error Resume Next 'D.McRitchie, 2004-06-05 Cells.SpecialCells(xlCellTypeValidation).Select If Err.number <> 0 Then MsgBox "SelectAllValidationss" & Chr(10) & Err.number & " " & Err.Description End If End Sub Sub CommentsToValidationBox() Dim cell As Range, rng As Range 'D.McRitchie, 2004-06-05 On Error Resume Next Set rng = Intersect(Selection, Selection.SpecialCells(xlCellTypeComments)) If rng Is Nothing Then MsgBox "No Cell Comments in Selection for conversion to validation" Exit Sub End If On Error GoTo 0 For Each cell In rng With cell .Validation.Delete .Validation.Add Type:=xlValidateInputOnly, _ AlertStyle:=xlValidAlertStop, Operator _ :=xlBetween .Validation.InputMessage = .Comment.Text End With cell.Comment.Delete Next cell 'rng.Comment.Delete End Sub Sub CommentsFromValidationBox() Dim cell As Range, rng As Range 'D.McRitchie, 2004-06-05 On Error Resume Next Set rng = Intersect(Selection, Selection.SpecialCells(xlCellTypeAllValidation)) If rng Is Nothing Then MsgBox "No Validation Cells in Selection for conversion to Cell Comments" Exit Sub End If On Error GoTo 0 For Each cell In rng With cell If .Comment Is Nothing Then .AddComment.Text .Validation.InputMessage '-- ignoring .Validation.InputTitle Else .Comment.Text .Validation.InputMessage '-- ignoring exiting comment and .validation.inputtitle End If End With Next cell rng.Validation.Delete End Sub Sub pastespecialcomments() Selection.PasteSpecial Paste:=xlPasteComments, _ Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False End Sub Function SUM_str_inComments(str As String, _ Optional rng_p As Range) As Double '2004-11-17 D.McRitchie Dim cell As Range, rng As Range Dim tot As Double, cmt As Comment Dim strxx As String Dim rng1 As Range Dim rng2 As Range tot = 0 If rng_p Is Nothing Then Set rng = Cells.SpecialCells(xlCellTypeConstants) Else Set rng = rng_p End If MsgBox rng.Address(0, 0) For Each cmt In ActiveSheet.Comments MsgBox cell.Address If Intersect(cmt.Address.Range, rng) Is Nothing Then Else MsgBox cell.Address If InStr(1, strxx, str, 1) Then If IsNumeric(cell.Value) Then tot = tot + cell.Value End If End If Next cell done: SUM_str_inComments = tot End Function Sub dumbo() '2004-11-17 D.McRitchie Dim cell As Range, rng As Range Dim tot As Double, cmt As Comment Dim str As String, strxx As String str = "aa" Set rng = Cells.SpecialCells(xlConstants, xlNumbers) rng.Select tot = 0 ' On Error GoTo done For Each cell In Intersect(rng.SpecialCells(xlConstants, xlNumbers), _ rng.SpecialCells(xlCellTypeComments)) MsgBox cell.Address(0, 0) & " -- " & cell.Comment.Text strxx = cell.Comment.Text If InStr(1, strxx, str, 1) Then tot = tot + cell.Value End If Next cell done: MsgBox tot End Sub Function Subtract(a, b) 'Result must not exceed 14 digits Subtract = CDec(a) - (b) End Function Sub toggle_comment_indicator() '2005-03-31, D.McRitchie, misc, ccomment.htm If Application.DisplayCommentIndicator = xlNoIndicator Then Application.DisplayCommentIndicator = xlCommentIndicatorOnly ElseIf Application.DisplayCommentIndicator = xlCommentIndicatorOnly Then Application.DisplayCommentIndicator = xlCommentAndIndicator Else Application.DisplayCommentIndicator = xlNoIndicator End If End Sub