Sub ChangesInRed()
feature The Tools...Track Changes feature must be turned on For the workbook being _
examined Macro must be In a different workbook than the one being examined Workbook _
being examined will be saved when the macro begins executing
Dim cel As Range
Dim wsName As String, celAddr As String
Dim ws As Worksheet
Dim wb As Workbook
Set wb = ActiveWorkbook
With wb
If .Name = ThisWorkbook.Name Then
MsgBox Title:="Error message", prompt:="This macro will not work on " & _
"the same workbook that contains the macro." & Chr(10) & _
"Please click on a cell in a different workbook using the " & _
"Track Changes feature"
Exit Sub
End If
If .KeepChangeHistory = False Then GoTo errhandler
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error GoTo errhandler
.Save
.HighlightChangesOptions When:=xlAllChanges, Who:="Everyone"
.ListChangesOnNewSheet = True
.HighlightChangesOnScreen = True
.Worksheets(.Worksheets.Count).Columns("F:G").Copy
End With
ThisWorkbook.Activate
ThisWorkbook.Worksheets.Add
Set ws = ActiveSheet
ws.Range("F1").PasteSpecial
Application.CutCopyMode = False
For Each cel In Range(Cells(2, 6), Cells(65536, 6).End(xlUp)).Cells
wsName = cel.Value
celAddr = cel.Offset(0, 1).Value
wb.Worksheets(wsName).Range(celAddr).Font.ColorIndex = 3
Next cel
ActiveSheet.Delete
wb.Activate
wb.ListChangesOnNewSheet = False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
On Error GoTo 0
Exit Sub
errhandler:
MsgBox Title:="Error message", prompt:="Track changes feature must " & _
"be turned on for active workbook"
On Error GoTo 0
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Exit Sub
End Sub
|