Info

cmtCount = 2

On Error Resume Next

Set ws = ActiveSheet

If ws Is Nothing Then Exit Sub On Error GoTo 0

Application.ScreenUpdating = False Set wb = Workbooks.Add(xlWorksheet)

With wb.Sheets(1 .Range("$A$1 .Range("$B$1 .Range("$C$1 .Range("$D$1 .Range("$E$1 End With

Author"

Book"

Sheet"

Range"

Comment"

For Each cmt In ws.Comments

With wb.Sheets(1)

.Cells(cmtCount, .Cells(cmtCount, .Cells(cmtCount, .Cells(cmtCount, .Cells(cmtCount, End With

2) = cmt.Parent.Parent.Parent.Name

3) = cmt.Parent.Parent.Name

4) = cmt.Parent.Address

5) = CleanComment(cmt.author, cmt.Text)

cmtCount = cmtCount + 1

Next wb.Sheets(1).UsedRange.WrapText = False

Application.ScreenUpdating = True

Set ws = Nothing

Set wb = Nothing End Sub

Private Function CleanComment(author As String, cmt As String) As String Dim tmp As String tmp = Application.WorksheetFunction.Substitute(cmt, author & ":", "") tmp = Application.WorksheetFunction.Substitute(tmp, Chr(10), "")

CleanComment = tmp End Function

0 0

Post a comment