Macro to Search for Comments in Closed Workbooks

[jkouvel]

Hello - I'm seeking a macro that would help me identify which files in a folder (including subfolders) have review comments in them. I searched through other posts but I couldn't find an answer or, I found something that could possibly be applied to my scenario (e.g. searching for 'x' in closed worksheets), but I'm not sure how to modify it accordingly to find comments vs. values or specific text. Example would be this thread: https://www.mrexcel.com/board/threads/finding-data-in-closed-workbooks-with-vba.950934/

In a 'good, better, best' fashion, my primary goal is to create a new spreadsheet that would list all file names where there are comments in worksheets (on any/all tabs); a reach goal would be to pull the comment detail into the new spreadsheet. But honestly, I'd be happy enough just knowing where to narrow my search to clear and remove comments in files before they're archived.

I do have a current macro designed to create a new sheet within the same workbook and listing all the comments with the respective tab, cell reference, and cell content but not sure if that could be modified to use to search across closed files in a folder. Any help would be appreciated!!

As a note, I'm using Excel 2019.

Sub ShowCommentsAllSheets()

'summarizes all review comment boxes in workbook
  Application.ScreenUpdating = False

  Dim commrange As Range
  Dim mycell As Range
  Dim ws As Worksheet
  Dim newwks As Worksheet
  Dim i As Long

Set newwks = Worksheets.Add

 newwks.Range("A5:D5").Value = _
     Array("Tab", "Cell", "Cell Value / Description", "Review Comment")
  
For Each ws In ActiveWorkbook.Worksheets
  On Error Resume Next
  Set commrange = ws.Cells.SpecialCells(xlCellTypeComments)
  On Error GoTo 0

  If commrange Is Nothing Then
    'do nothing
  Else
 
    i = newwks.Cells(Rows.Count, 1).End(xlUp).Row

    For Each mycell In commrange
       With newwks
         i = i + 1
         On Error Resume Next
         .Cells(i, 1).Value = ws.Name
         .Cells(i, 2).Value = mycell.Address
         .Cells(i, 3).Value = mycell.Value
         .Cells(i, 4).Value = mycell.Comment.Text
       End With
    Next mycell
  End If
  Set commrange = Nothing
Next ws
 
 
'format cells for no wrapping, remove line break
newwks.Cells.WrapText = False
newwks.Columns("D:D").Replace What:=Chr(10), _
  Replacement:=" ", LookAt:=xlPart, _
  SearchOrder:=xlByRows, MatchCase:=False, _
  SearchFormat:=False, ReplaceFormat:=False

Application.ScreenUpdating = True


'adjusts width and formatting of cells
Columns("C:D").Select
With Selection
.ColumnWidth = 75
.WrapText = True
End With

Columns("A:D").Select
With Selection
.VerticalAlignment = xlTop
.EntireColumn.AutoFit
End With

Columns("C").Select
With Selection
.HorizontalAlignment = xlHAlignLeft
.WrapText = True
End With

Columns("A").Select
With Selection
.HorizontalAlignment = xlHAlignLeft
End With


'minimum column width
Dim mCell As Range
Application.ScreenUpdating = False

For Each mCell In Columns("A")
mCell.EntireColumn.AutoFit
If mCell.EntireColumn.ColumnWidth > 15 Then _
mCell.EntireColumn.ColumnWidth = 15
Next mCell

For Each mCell In Columns("C")
mCell.EntireColumn.AutoFit
If mCell.EntireColumn.ColumnWidth > 50 Then _
mCell.EntireColumn.ColumnWidth = 50
Next mCell

Application.ScreenUpdating = True

Dim cl As Range

For Each cl In Columns("C:D")
If cl.WrapText Then cl.Rows.AutoFit
Next



'add titles and date to sheet
Range("A1").Value = "Review Comments"
Range("A1").Font.Size = 14
Range("A1").Font.FontStyle = "Bold"

Range("A2").Value = ActiveWorkbook.Name
Range("A2").Font.Size = 12
Range("A2").Font.FontStyle = "Bold"

With Range("D1")
.Value = Date
.NumberFormat = "m/d/yy"
End With



'add borders to header row
Range("A5:D5").Borders(xlEdgeLeft).LineStyle = xlContinuous
Range("A5:D5").Borders(xlEdgeRight).LineStyle = xlContinuous
Range("A5:D5").Borders(xlEdgeTop).LineStyle = xlContinuous
Range("A5:D5").Borders(xlEdgeBottom).LineStyle = xlContinuous
Range("A5:D5").Borders(xlInsideVertical).LineStyle = xlContinuous
Range("A5:D5").Interior.ColorIndex = 37



'formats borders for non-blank rows
Dim lngRows As Long

 With ActiveSheet
 For lngRows = 6 To .Cells(.Rows.Count, 1).End(xlUp).Row
 .Range("A" & lngRows & ":D" & lngRows).Borders(xlEdgeBottom).LineStyle = xlContinuous
 Next
 End With


'page formatting
With ActiveSheet.PageSetup
    .Zoom = False
    .FitToPagesWide = 1
    .LeftMargin = Application.InchesToPoints(0.5)
    .RightMargin = Application.InchesToPoints(0.5)
    .TopMargin = Application.InchesToPoints(0.5)
    .BottomMargin = Application.InchesToPoints(0.5)
End With


'filter out empty rows
ActiveSheet.Range("$A$5:$D$400").AutoFilter Field:=4, Criteria1:="<>", Operator:=xlFilterValues
    ActiveWindow.ScrollRow = 1


'renames sheet
ActiveSheet.Name = "Review Notes"


'formats new comment tab
For Each mCell In Columns("A:B")
mCell.EntireColumn.AutoFit
If mCell.EntireColumn.ColumnWidth > 15 Then _
mCell.EntireColumn.ColumnWidth = 15
Next mCell

For Each mCell In Columns("C")
mCell.EntireColumn.AutoFit
If mCell.EntireColumn.ColumnWidth > 50 Then _
mCell.EntireColumn.ColumnWidth = 50
Next mCell

For Each mCell In Columns("D")
mCell.EntireColumn.AutoFit
If mCell.EntireColumn.ColumnWidth > 75 Then _
mCell.EntireColumn.ColumnWidth = 75
Next mCell

Application.ScreenUpdating = True

For Each cl In Columns("A:D")
If cl.WrapText Then cl.Rows.AutoFit
Next

Columns("A").Select
With Selection
.HorizontalAlignment = xlHAlignLeft
End With


'changes new tab color
Sheets("Review Notes").Tab.ColorIndex = 3
'3=Red , 4=green,5=blue,6=yellow,etc.


End Sub