I was wondering in someone couild help me with some code.

I have a spreadsheet in which I have step numbers descending in column A, an
associated descriptive operation in column B and a material in column C.

The three columns encompass cells A18:C87.

I enter cell comments into various cells down in columns B and C and
sometimes a particular row may have cell comments in both Column B and C.

What I would like is to have a summary table which reads down columns A,B
and C and summarizes which steps have comments and what the comments are.

The summary table would have the step number in Column Q and the comments in
Column R(starting in Q2/R2). As mentioned above, some of the step numbers
would be entered twice in the summary table reflecting the presence of
comments in both B and C for a particular step.

Ideally I would want to be able to clear and update the summary table when I
insert new rows or move rows around in the range A18:C87.

Can anyone help?

Here's a macro [main macro is 'commentslist' that lists the comments to a new
worksheet. Hopefully, you can re-work it to your needs.

'/================================================/
Sub CommentsList()
'Purpose of this VBA program is to find and list all comments
'in a Workbook
'
'For use with EXCEL 97 or higher
'
' Created 04/10/2002
'
' Gary L. Brown, Kinneson Corp
'
'
Dim aryHiddensheets()
Dim bln1Sheet As Boolean
Dim iRow As Long, iColumn As Long
Dim dblLastRow As Long
Dim iCommentCount As Long
Dim i As Long
Dim x As Long, y As Long, iWorksheets As Long
Dim objOutputArea As Object, objCell As Object
Dim objComment As Object, objSheet As Object
Dim strResultsTableName As String
Dim strCellAddress As String, strExtraSheet As String
Dim strOrigCalcStatus As String

On Error Resume Next

strResultsTableName = "Comments_List"
bln1Sheet = False

'save calculation setting
Select Case Application.Calculation
Case xlCalculationAutomatic
strOrigCalcStatus = "Automatic"
Case xlCalculationManual
strOrigCalcStatus = "Manual"
Case xlCalculationSemiautomatic
strOrigCalcStatus = "SemiAutomatic"
Case Else
strOrigCalcStatus = "Automatic"
End Select

'set workbook to manual
Application.Calculation = xlManual

'Count number of worksheets in workbook
iWorksheets = ActiveWorkbook.Sheets.Count

'redim array
ReDim aryHiddensheets(1 To iWorksheets)

'put hidden sheets in an array, then unhide the sheets
x = 0
y = 0
For Each objSheet In ActiveWorkbook.Sheets
y = y + 1
If objSheet.Visible < True Then
x = x + 1
aryHiddensheets(x) = objSheet.name
objSheet.Visible = True
End If
Next objSheet

'Check for duplicate Worksheet name
i = ActiveWorkbook.Sheets.Count

'Add worksheet if there is only one worksheet so error will not
' occur if the worksheet must be deleted. There HAS to be at
' least one worksheet in a workbook
If i = 1 Then
Worksheets.Add.Move after:=Worksheets(i)
i = ActiveWorkbook.Sheets.Count
strExtraSheet = Worksheets(2).name
bln1Sheet = True
End If

For x = 1 To i
If Windows.Count = 0 Then Exit Sub
If UCase(Worksheets(x).name) = UCase(strResultsTableName) Then
Worksheets(x).Activate
If Err.Number = 9 Then
Exit For
End If
Application.DisplayAlerts = False 'turn warnings off
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True 'turn warnings on
End If
Next

'Add new worksheet at end of workbook
' where results will be located
Worksheets.Add.Move after:=Worksheets(Worksheets.Count)

'if an extra worksheet was added because there was only one worksheet
' in the original workbook, delete it now
If bln1Sheet Then
Application.DisplayAlerts = False
Sheets(strExtraSheet).Delete
Application.DisplayAlerts = True
bln1Sheet = True
End If

'Name the new worksheet and set up Titles
ActiveWorkbook.ActiveSheet.name = strResultsTableName
ActiveWorkbook.ActiveSheet.Range("A1").value = "Worksheet"
ActiveWorkbook.ActiveSheet.Range("B1").value = "Address"
ActiveWorkbook.ActiveSheet.Range("C1").value = "Col"
ActiveWorkbook.ActiveSheet.Range("D1").value = "Row"
ActiveWorkbook.ActiveSheet.Range("E1").value = "Cell Value"
ActiveWorkbook.ActiveSheet.Range("F1").value = "Comment"


'Count number of worksheets in workbook
iWorksheets = ActiveWorkbook.Sheets.Count

'Initialize row and column counts for putting info into
' strResultsTableName sheet
iRow = 1
iColumn = 0

'Go through one Worksheet at a time
For x = 1 To iWorksheets
'Go to Next Worksheet
Worksheets(x).Activate
'Initialize count variable
iCommentCount = 0

If ActiveWorkbook.ActiveSheet.name < strResultsTableName Then
'Identify the cells with formulas and text/values in them
Set objComment = Nothing
'Establish cells with comments in them
On Error Resume Next
Set objComment = ActiveSheet.Cells.SpecialCells(xlCellTypeComments)

iCommentCount = objComment.Count

'if there is a comment
If iCommentCount < 0 Then
'Process each cell with a value or text in it
Set objOutputArea = _
ActiveWorkbook.Sheets(strResultsTableName).Range(" A1")
For Each objCell In objComment
With objOutputArea
'put information into StrResultstablename Worksheet
.Offset(iRow, iColumn) = " " & ActiveSheet.name
.Offset(iRow, iColumn + 1) = _
objCell.AddressLocal(rowabsolute:=False, _
columnabsolute:=False)
strCellAddress = _
objCell.AddressLocal(rowabsolute:=False, _
columnabsolute:=False)
.Hyperlinks.Add _
Anchor:=.Offset(iRow, iColumn + 1), _
Address:="", SubAddress:=Chr(39) & _
ActiveSheet.name & _
Chr(39) & "!" & _
objCell.AddressLocal(rowabsolute:=False, _
columnabsolute:=False)
.Offset(iRow, iColumn + 2) = _
funcCol(strCellAddress)
.Offset(iRow, iColumn + 3) = _
funcRow(strCellAddress)
.Offset(iRow, iColumn + 4) = " " & _
objCell.value
.Offset(iRow, iColumn + 5) = " " & _
objCell.Comment.Text
iRow = iRow + 1

End With

If iRow = 65536 Then
iColumn = iColumn + 8
iRow = 1
End If

Next objCell

End If
End If
Next x

If IsEmpty(Range("A2")) Then
Application.DisplayAlerts = False 'turn warnings off
Application.ActiveSheet.Delete
'ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True 'turn warnings on
MsgBox "No Comments where located in..." & vbCr & Chr(34) & _
Application.ActiveWorkbook.name & Chr(34), vbInformation + vbOKOnly,
"Warning..."
GoTo exit_Sub
End If

'format the worksheet
Range("A2").Select
ActiveWindow.FreezePanes = True
ActiveWindow.Zoom = 75
Columns("F:F").ColumnWidth = 100
Cells.Select
Cells.EntireColumn.AutoFit
Columns("F:F").Select
If Selection.ColumnWidth 50 Then
Selection.ColumnWidth = 50
End If
Selection.WrapText = True
Cells.Select
Cells.EntireRow.AutoFit

Range("A1:A1").Select
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, _
Key2:=Range("D2") _
, Order2:=xlAscending, Key3:=Range("C2"), _
Order3:=xlAscending, HEADER:= _
xlGuess, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom

Columns("A:F").VerticalAlignment = xlTop

Rows("1:1").Select
Selection.Insert Shift:=xlDown
dblLastRow = ActiveSheet.Cells.SpecialCells(xlLastCell).Row
If dblLastRow + 100 <= 65000 Then
dblLastRow = dblLastRow + 100
End If

ActiveWorkbook.ActiveSheet.Range("A1").WrapText = False
' ActiveWorkbook.ActiveSheet.Range("A1").value = _
' dblLastRow & " Comment(s) found."
Application.ActiveSheet.Range("A1").Formula = "=SUBTOTAL(3,A3:A" & _
dblLastRow & ") & " & Chr(34) & " Comment(s) found." & Chr(34)
Selection.Font.Bold = True

Range("A2").Select

'formatting printing
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$2"
End With
With ActiveSheet.PageSetup
.LeftMargin = Application.InchesToPoints(0.75)
.RightMargin = Application.InchesToPoints(0.25)
.TopMargin = Application.InchesToPoints(0.5)
.BottomMargin = Application.InchesToPoints(0.5)
.HeaderMargin = Application.InchesToPoints(0.25)
.FooterMargin = Application.InchesToPoints(0.25)
.Orientation = xlPortrait
.Order = xlOverThenDown
.Zoom = 80
.LeftHeader = "&""Tms Rmn,Bold""&U&A"
.LeftFooter = "Printed: &D - &T"
.CenterFooter = "Page &P of &N"
.RightFooter = "&F-&A"
.PrintGridlines = True
End With
ActiveWindow.Zoom = 75

Application.Dialogs(xlDialogWorkbookName).Show

exit_Sub:

're-hide previously hidden sheets
On Error Resume Next
y = UBound(aryHiddensheets)
For x = 1 To y
Worksheets(aryHiddensheets(x)).Visible = False
Next

're-set to original calculation method
Select Case strOrigCalcStatus
Case "Automatic"
Application.Calculation = xlCalculationAutomatic
Case "Manual"
Application.Calculation = xlCalculationManual
Case "SemiAutomatic"
Application.Calculation = xlCalculationSemiautomatic
Case Else
Application.Calculation = xlCalculationAutomatic
End Select

End Sub
'/================================================/
Private Function funcCol(strAddress As String) As String
Dim i As Integer

For i = 1 To Len(strAddress)
If Asc(Mid(strAddress, i, 1)) < 58 Then
funcCol = Left(strAddress, i - 1)
Exit Function
End If
Next i

End Function
'===========================================
Private Function funcRow(strAddress As String) As String
Dim i As Integer

For i = 1 To Len(strAddress)
If Asc(Mid(strAddress, i, 1)) < 58 Then
funcRow = Right(strAddress, Len(strAddress) - i + 1)
Exit Function
End If
Next i

End Function
'================================================



--
Hope this helps.
If it does, please click the Yes button.
Thanks in advance for your feedback.
Gary Brown


"Roger on Excel" wrote:

I was wondering in someone couild help me with some code.

I have a spreadsheet in which I have step numbers descending in column A, an
associated descriptive operation in column B and a material in column C.

The three columns encompass cells A18:C87.

I enter cell comments into various cells down in columns B and C and
sometimes a particular row may have cell comments in both Column B and C.

What I would like is to have a summary table which reads down columns A,B
and C and summarizes which steps have comments and what the comments are.

The summary table would have the step number in Column Q and the comments in
Column R(starting in Q2/R2). As mentioned above, some of the step numbers
would be entered twice in the summary table reflecting the presence of
comments in both B and C for a particular step.

Ideally I would want to be able to clear and update the summary table when I
insert new rows or move rows around in the range A18:C87.

Can anyone help?

Hi Gary,

Thanks for the code. Very effective and works well at gathering all comments
from all sheets. I will have to take a look to see if I can modify it for my
needs, although it is a little beyond my capabilities as a novice macro code
hack!

Best regards,

Roger.



"Gary Brown" wrote:

Here's a macro [main macro is 'commentslist' that lists the comments to a new
worksheet. Hopefully, you can re-work it to your needs.

'/================================================/
Sub CommentsList()
'Purpose of this VBA program is to find and list all comments
'in a Workbook
'
'For use with EXCEL 97 or higher
'
' Created 04/10/2002
'
' Gary L. Brown, Kinneson Corp
'
'
Dim aryHiddensheets()
Dim bln1Sheet As Boolean
Dim iRow As Long, iColumn As Long
Dim dblLastRow As Long
Dim iCommentCount As Long
Dim i As Long
Dim x As Long, y As Long, iWorksheets As Long
Dim objOutputArea As Object, objCell As Object
Dim objComment As Object, objSheet As Object
Dim strResultsTableName As String
Dim strCellAddress As String, strExtraSheet As String
Dim strOrigCalcStatus As String

On Error Resume Next

strResultsTableName = "Comments_List"
bln1Sheet = False

'save calculation setting
Select Case Application.Calculation
Case xlCalculationAutomatic
strOrigCalcStatus = "Automatic"
Case xlCalculationManual
strOrigCalcStatus = "Manual"
Case xlCalculationSemiautomatic
strOrigCalcStatus = "SemiAutomatic"
Case Else
strOrigCalcStatus = "Automatic"
End Select

'set workbook to manual
Application.Calculation = xlManual

'Count number of worksheets in workbook
iWorksheets = ActiveWorkbook.Sheets.Count

'redim array
ReDim aryHiddensheets(1 To iWorksheets)

'put hidden sheets in an array, then unhide the sheets
x = 0
y = 0
For Each objSheet In ActiveWorkbook.Sheets
y = y + 1
If objSheet.Visible < True Then
x = x + 1
aryHiddensheets(x) = objSheet.name
objSheet.Visible = True
End If
Next objSheet

'Check for duplicate Worksheet name
i = ActiveWorkbook.Sheets.Count

'Add worksheet if there is only one worksheet so error will not
' occur if the worksheet must be deleted. There HAS to be at
' least one worksheet in a workbook
If i = 1 Then
Worksheets.Add.Move after:=Worksheets(i)
i = ActiveWorkbook.Sheets.Count
strExtraSheet = Worksheets(2).name
bln1Sheet = True
End If

For x = 1 To i
If Windows.Count = 0 Then Exit Sub
If UCase(Worksheets(x).name) = UCase(strResultsTableName) Then
Worksheets(x).Activate
If Err.Number = 9 Then
Exit For
End If
Application.DisplayAlerts = False 'turn warnings off
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True 'turn warnings on
End If
Next

'Add new worksheet at end of workbook
' where results will be located
Worksheets.Add.Move after:=Worksheets(Worksheets.Count)

'if an extra worksheet was added because there was only one worksheet
' in the original workbook, delete it now
If bln1Sheet Then
Application.DisplayAlerts = False
Sheets(strExtraSheet).Delete
Application.DisplayAlerts = True
bln1Sheet = True
End If

'Name the new worksheet and set up Titles
ActiveWorkbook.ActiveSheet.name = strResultsTableName
ActiveWorkbook.ActiveSheet.Range("A1").value = "Worksheet"
ActiveWorkbook.ActiveSheet.Range("B1").value = "Address"
ActiveWorkbook.ActiveSheet.Range("C1").value = "Col"
ActiveWorkbook.ActiveSheet.Range("D1").value = "Row"
ActiveWorkbook.ActiveSheet.Range("E1").value = "Cell Value"
ActiveWorkbook.ActiveSheet.Range("F1").value = "Comment"


'Count number of worksheets in workbook
iWorksheets = ActiveWorkbook.Sheets.Count

'Initialize row and column counts for putting info into
' strResultsTableName sheet
iRow = 1
iColumn = 0

'Go through one Worksheet at a time
For x = 1 To iWorksheets
'Go to Next Worksheet
Worksheets(x).Activate
'Initialize count variable
iCommentCount = 0

If ActiveWorkbook.ActiveSheet.name < strResultsTableName Then
'Identify the cells with formulas and text/values in them
Set objComment = Nothing
'Establish cells with comments in them
On Error Resume Next
Set objComment = ActiveSheet.Cells.SpecialCells(xlCellTypeComments)

iCommentCount = objComment.Count

'if there is a comment
If iCommentCount < 0 Then
'Process each cell with a value or text in it
Set objOutputArea = _
ActiveWorkbook.Sheets(strResultsTableName).Range(" A1")
For Each objCell In objComment
With objOutputArea
'put information into StrResultstablename Worksheet
.Offset(iRow, iColumn) = " " & ActiveSheet.name
.Offset(iRow, iColumn + 1) = _
objCell.AddressLocal(rowabsolute:=False, _
columnabsolute:=False)
strCellAddress = _
objCell.AddressLocal(rowabsolute:=False, _
columnabsolute:=False)
.Hyperlinks.Add _
Anchor:=.Offset(iRow, iColumn + 1), _
Address:="", SubAddress:=Chr(39) & _
ActiveSheet.name & _
Chr(39) & "!" & _
objCell.AddressLocal(rowabsolute:=False, _
columnabsolute:=False)
.Offset(iRow, iColumn + 2) = _
funcCol(strCellAddress)
.Offset(iRow, iColumn + 3) = _
funcRow(strCellAddress)
.Offset(iRow, iColumn + 4) = " " & _
objCell.value
.Offset(iRow, iColumn + 5) = " " & _
objCell.Comment.Text
iRow = iRow + 1

End With

If iRow = 65536 Then
iColumn = iColumn + 8
iRow = 1
End If

Next objCell

End If
End If
Next x

If IsEmpty(Range("A2")) Then
Application.DisplayAlerts = False 'turn warnings off
Application.ActiveSheet.Delete
'ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True 'turn warnings on
MsgBox "No Comments where located in..." & vbCr & Chr(34) & _
Application.ActiveWorkbook.name & Chr(34), vbInformation + vbOKOnly,
"Warning..."
GoTo exit_Sub
End If

'format the worksheet
Range("A2").Select
ActiveWindow.FreezePanes = True
ActiveWindow.Zoom = 75
Columns("F:F").ColumnWidth = 100
Cells.Select
Cells.EntireColumn.AutoFit
Columns("F:F").Select
If Selection.ColumnWidth 50 Then
Selection.ColumnWidth = 50
End If
Selection.WrapText = True
Cells.Select
Cells.EntireRow.AutoFit

Range("A1:A1").Select
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, _
Key2:=Range("D2") _
, Order2:=xlAscending, Key3:=Range("C2"), _
Order3:=xlAscending, HEADER:= _
xlGuess, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom

Columns("A:F").VerticalAlignment = xlTop

Rows("1:1").Select
Selection.Insert Shift:=xlDown
dblLastRow = ActiveSheet.Cells.SpecialCells(xlLastCell).Row
If dblLastRow + 100 <= 65000 Then
dblLastRow = dblLastRow + 100
End If

ActiveWorkbook.ActiveSheet.Range("A1").WrapText = False
' ActiveWorkbook.ActiveSheet.Range("A1").value = _
' dblLastRow & " Comment(s) found."
Application.ActiveSheet.Range("A1").Formula = "=SUBTOTAL(3,A3:A" & _
dblLastRow & ") & " & Chr(34) & " Comment(s) found." & Chr(34)
Selection.Font.Bold = True

Range("A2").Select

'formatting printing
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$2"
End With
With ActiveSheet.PageSetup
.LeftMargin = Application.InchesToPoints(0.75)
.RightMargin = Application.InchesToPoints(0.25)
.TopMargin = Application.InchesToPoints(0.5)
.BottomMargin = Application.InchesToPoints(0.5)
.HeaderMargin = Application.InchesToPoints(0.25)
.FooterMargin = Application.InchesToPoints(0.25)
.Orientation = xlPortrait
.Order = xlOverThenDown
.Zoom = 80
.LeftHeader = "&""Tms Rmn,Bold""&U&A"
.LeftFooter = "Printed: &D - &T"
.CenterFooter = "Page &P of &N"
.RightFooter = "&F-&A"
.PrintGridlines = True
End With
ActiveWindow.Zoom = 75

Application.Dialogs(xlDialogWorkbookName).Show

exit_Sub:

're-hide previously hidden sheets
On Error Resume Next
y = UBound(aryHiddensheets)
For x = 1 To y
Worksheets(aryHiddensheets(x)).Visible = False
Next

're-set to original calculation method
Select Case strOrigCalcStatus
Case "Automatic"
Application.Calculation = xlCalculationAutomatic
Case "Manual"
Application.Calculation = xlCalculationManual
Case "SemiAutomatic"
Application.Calculation = xlCalculationSemiautomatic
Case Else
Application.Calculation = xlCalculationAutomatic
End Select

End Sub
'/================================================/
Private Function funcCol(strAddress As String) As String
Dim i As Integer

For i = 1 To Len(strAddress)
If Asc(Mid(strAddress, i, 1)) < 58 Then
funcCol = Left(strAddress, i - 1)
Exit Function
End If
Next i

End Function
'===========================================
Private Function funcRow(strAddress As String) As String
Dim i As Integer

For i = 1 To Len(strAddress)
If Asc(Mid(strAddress, i, 1)) < 58 Then