December 4, 2021
This makes NO sense. On my test file, which only contains comments and replies from me, it works just fine. But when I try it on my live file, it comes up as "No comments for each of the 3 sheets". Sheets 1 and 3 do NOT contain any comments on my live file, sheet 2 does. The revised code is below, just in case I messed something else up. First, showing how the comments appear on Sheet2 of my live file. Next the "print" showing comments at the end if you print your file. Again, this file DOES contain comments. And 3rd the dialog boxes showing no comments. I don't even know why these "nag" dialog boxes appear. Box I clicked OK on each. And my current code is at the bottom if I made all the corrections properly.
Sub ListCommentsRepliesThreaded5()
Application.ScreenUpdating = False
Dim myCmt As CommentThreaded
Dim myRp As CommentThreaded
Dim curwks As Worksheet
Dim newwks As Worksheet
Dim myList As ListObject
Dim i As Long
Dim iR As Long
Dim iRCol As Long
Dim ListCols As Long
Dim cmtCount As Long
Dim wks As Worksheet
Dim NewRow As ListRow
If SheetExists("Comments") = False Then
Set newwks = Worksheets.Add
newwks.Name = "Comments"
Else
Set newwks = ThisWorkbook.Worksheets("Comments")
newwks.UsedRange.Clear
End If
newwks.Range("A1:G1").Value = Array("Number", "Sheet", "Cell", "Author", "Date", "Replies", "Text")
Set myList = newwks.ListObjects.Add(xlSrcRange, newwks.Range("A1:G2"), , xlYes)
myList.Name = "Comments"
myList.TableStyle = "TableStyleLight8"
i = 1
For Each wks In ThisWorkbook.Worksheets
If Not wks.Name Like "Comments" Then
Set curwks = wks
cmtCount = curwks.CommentsThreaded.Count
If cmtCount = 0 Then
MsgBox "No threaded comments found in " & wks.Name
'Exit Sub
End If
For Each myCmt In curwks.CommentsThreaded
With newwks
i = i + 1
On Error Resume Next
.Cells(i, 1).Value = i - 1
.Cells(i, 2).Value = wks.Name
.Cells(i, 3).Value = myCmt.Parent.Address
.Cells(i, 4).Value = myCmt.Author.Name
.Cells(i, 5).Value = myCmt.Date
.Cells(i, 6).Value = myCmt.Replies.Count
.Cells(i, 7).Value = myCmt.Text
If myCmt.Replies.Count > 1 Then
iR = 1
iRCol = 8
For iR = 1 To myCmt.Replies.Count
.Cells(1, iRCol).Value = "Reply " & iR
.Cells(i, iRCol).Value _
= myCmt.Replies(iR).Author.Name _
& vbCrLf _
& myCmt.Replies(iR).Date _
& vbCrLf _
& myCmt.Replies(iR).Text
iRCol = iRCol + 1
Next iR
End If
End With
Next myCmt
End If
Next wks
With myList.DataBodyRange
.Cells.VerticalAlignment = xlTop
.Columns.EntireColumn.ColumnWidth = 30
.Cells.WrapText = True
.Columns.EntireColumn.AutoFit
.rows.EntireRow.AutoFit
End With
Application.ScreenUpdating = True
End Sub
Function SheetExists(ByVal ShName As String) As Boolean
On Error Resume Next
SheetExists = Not ThisWorkbook.Worksheets(ShName) Is Nothing
End Function
Power Query
Power Pivot
Xtreme Pivot Tables
Excel for Decision Making
Excel for Finance
Excel Analysis Toolpak
Power BI
Excel
Word
Outlook
Excel Expert
Excel Customer Service
PowerPoint
November 8, 2013
If you don't want to see the "nag" dialog box, you can just remove the code that displays the message box.
If cmtCount = 0 Then
MsgBox "No threaded comments found in " & wks.Name
'Exit Sub
End If
I cannot help without a sample file that replicates the issues you mentioned.
December 4, 2021
I have attempted to fix this code, and I have numbered my files so I could go back to them and I am still having issues. This code works on my test file, but not on my live file.
Sub ListCommentsRepliesThreaded()
Application.ScreenUpdating = False
Dim myCmt As CommentThreaded
Dim myRp As CommentThreaded
Dim curwks As Worksheet
Dim newwks As Worksheet
Dim myList As ListObject
Dim i As Long
Dim iR As Long
Dim iRCol As Long
Dim ListCols As Long
Dim cmtCount As Long
Dim wks As Worksheet
Dim NewRow As ListRow
If SheetExists("Comments") = False Then
Set newwks = Worksheets.Add
newwks.Name = "Comments"
Else
Set newwks = ThisWorkbook.Worksheets("Comments")
newwks.UsedRange.Clear
End If
newwks.Range("A1:G1").Value = Array("Number", "Sheet", "Cell", "Author", "Date", "Replies", "Text")
Set myList = newwks.ListObjects.Add(xlSrcRange, newwks.Range("A1:G2"), , xlYes)
myList.Name = "Comments"
myList.TableStyle = "TableStyleLight8"
i = 1
For Each wks In ThisWorkbook.Worksheets
If Not wks.Name Like "Comments" Then
Set curwks = wks
cmtCount = curwks.CommentsThreaded.Count
If cmtCount = 0 Then
MsgBox "No threaded comments found in " * wks.Name
'Exit Sub
End If
For Each myCmt In curwks.CommentsThreaded
With newwks
i = i + 1
On Error Resume Next
.Cells(i, 1).Value = i - 1
.Cells(i, 2).Value = wks.Name
.Cells(i, 3).Value = myCmt.Parent.Address
.Cells(i, 4).Value = myCmt.Author.Name
.Cells(i, 5).Value = myCmt.Date
.Cells(i, 6).Value = myCmt.Replies.Count
.Cells(i, 7).Value = myCmt.Text
If myCmt.Replies.Count > 1 Then
iR = 1
iRCol = 8
For iR = 1 To myCmt.Replies.Count
.Cells(1, iRCol).Value = "Reply " & iR
.Cells(i, iRCol).Value _
= myCmt.Replies(iR).Author.Name _
& vbCrLf _
& myCmt.Replies(iR).Date _
& vbCrLf _
& myCmt.Replies(iR).Text
iRCol = iRCol + 1
Next iR
End If
End With
Next myCmt
End If
Next wks
With myList.DataBodyRange
.Cells.VerticalAlignment = xlTop
.Columns.EntireColumn.ColumnWidth = 30
.Cells.WrapText = True
.Columns.EntireColumn.AutoFit
.rows.EntireRow.AutoFit
End With
Application.ScreenUpdating = True
End Sub
Function SheetExists(ByVal ShName As String) As Boolean
On Error Resume Next
SheetExists = Not ThisWorkbook.Worksheets(ShName) Is Nothing
End Function
1 Guest(s)