Sorry for no response, I have been out of town again. I am attempting to create a "dummy file. But I am having to create something from scratch, as I cannot post my live file. I am working on it.
My test file seems to work file (file attached), however my live file gives an error Runtime error 13 Type Mismatch, and then results in the comments sheets with NO comments, but there are a ton of comments in this workbook. And NO my live data file is not protected, and macros were enabled.
No file attached.
Can you upload a screenshot with the line in code that returns that error? When you press debug, that line is highlighted.
@Catalin,
Sorry for the delay, we have had a busy 2 weeks preparing for month end. Attached are the screenshots you requested. Sorry about forgetting the test, attached this time.
Hi Sherry,
That error was solved, you are using an old version. Use the file sent on august 25
August 24, 2022 - 3:45 pmMy mistake:Instead of :
MsgBox "No threaded comments found in " * wks.Name
Should be:
MsgBox "No threaded comments found in " & wks.Name
Here is another advice that is not applied in your latest file:
This line:
i=1
should be above this line (outside any loop):
For Each wks In ThisWorkbook.Worksheets
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
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.
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
