Hi Narayan,
I have readymade macro having three macro buttons.
Button1 Number Commets-- which give number to cell comments like 1,2,3,...etc
Button2 clear Number-- which is used to remove number given to cell comments.
Button3 List Comments--gives output in new sheet having columns like Sr.No, Name, Current Value of cell, Address of cell having comment, and Commnet value.
But I need additional two colums. viz.,
a) The Product Code corresponding to which the comment was made
b) The column label ( whether the correction was for BRAND1 , BRAND2 ,... ) where the correction was made.
which contains following code
Option Explicit
' Developed by Contextures Inc.
' www.contextures.com
Sub RemoveIndicatorShapes()
Dim ws As Worksheet
Dim shp As Shape
Set ws = ActiveSheet
For Each shp In ws.Shapes
If Left(shp.Name, 6) = "CmtNum" Then
shp.Delete
End If
Next shp
End Sub
Sub CoverCommentIndicator()
Dim ws As Worksheet
Dim cmt As Comment
Dim lCmt As Long
Dim rngCmt As Range
Dim shpCmt As Shape
Dim shpW As Double 'shape width
Dim shpH As Double 'shape height
Set ws = ActiveSheet
shpW = 8
shpH = 6
lCmt = 1
'clear any existing numbers
RemoveIndicatorShapes
For Each cmt In ws.Comments
Set rngCmt = cmt.Parent
With rngCmt
Set shpCmt = ws.Shapes.AddShape(msoShapeRectangle, _
rngCmt.Offset(0, 1).Left - shpW, .Top, shpW, shpH)
End With
With shpCmt
.Name = "CmtNum" & .Name
With .Fill
.ForeColor.SchemeColor = 9 'white
.Visible = msoTrue
.Solid
End With
With .Line
.Visible = msoTrue
.ForeColor.SchemeColor = 64 'automatic
.Weight = 0.25
End With
With .TextFrame
.Characters.Text = lCmt
.Characters.Font.Size = 6
.Characters.Font.ColorIndex = xlAutomatic
.MarginLeft = 0#
.MarginRight = 0#
.MarginTop = 0#
.MarginBottom = 0#
.HorizontalAlignment = xlCenter
End With
.Top = rngCmt.Top + 0.001
End With
lCmt = lCmt + 1
Next cmt
End Sub
Sub showcomments()
'posted by Dave Peterson 2003-05-16
Application.ScreenUpdating = False
Dim commrange As Range
Dim mycell As Range
Dim curwks As Worksheet
Dim newwks As Worksheet
Dim i As Long
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
Set newwks = Worksheets.Add
newwks.Range("A1:E1").Value = _
Array("Number", "Name", "Value", "Address", "Comment")
i = 1
For Each mycell In commrange
With newwks
i = i + 1
On Error Resume Next
.Cells(i, 1).Value = i - 1
.Cells(i, 2).Value = mycell.Name.Name
.Cells(i, 3).Value = mycell.Value
.Cells(i, 4).Value = mycell.Address
.Cells(i, 5).Value = Replace(mycell.Comment.Text, Chr(10), " ")
End With
Next mycell
newwks.Cells.WrapText = False
newwks.Columns.AutoFit
Application.ScreenUpdating = True
End Sub
Is it possible to update the above makro as per my need? ....or we need to have new macro.
Regards,
Pragnesh
