I want to optimize this code by taking the Sub Parse and fold it into
an IF...THEN statement that will run for only certain spreadsheets
within a workbook. The workbook may contain up to 100 worksheets, not
all of the worksheets will need the Sub Parse run on them. How to I
make this code work Better? It works right now, but I want to optimize
it. Thanks in Advance.

Sub CompareSheets()
Compare Worksheets("Sheet1"), Worksheets("Sheet2")
End Sub
Sub Parse(WorkSheet1 As Worksheet, WorkSheet2 As Worksheet)
Sheets("Sheet1").Select
Columns("A:A").Select
Selection.TextToColumns DataType:=xlDelimited, _
ConsecutiveDelimiter:=True, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=True
Columns("A:A").Delete
Sheets("Sheet2").Select
Columns("A:A").Select
Selection.TextToColumns DataType:=xlDelimited, _
ConsecutiveDelimiter:=True, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=True
Columns("A:A").Delete
Sheets("Sheet3").Select
End Sub
Sub Compare(WorkSheet1 As Worksheet, WorkSheet2 As Worksheet)
Dim MyCell As Range
Dim r As Long, c As Integer
Dim lr1 As Long, lr2 As Long, lc1 As Integer, lc2 As Integer
Dim maxR As Long, maxC As Integer, cf1 As String, cf2 As String
Dim rptWB As Worksheet, DiffCount As Long
Application.ScreenUpdating = False
Application.StatusBar = "Comparing Sheets..."
Set rptWB = Worksheets.Add(, Sheet2, 1)
Call Parse(Worksheets("Sheet1"), Worksheets("Sheet2"))
With WorkSheet1.UsedRange
lr1 = .Rows.Count
lc1 = .Columns.Count
End With
With WorkSheet2.UsedRange
lr2 = .Rows.Count
lc2 = .Columns.Count
End With
maxR = lr1
maxC = lc1
If maxR < lr2 Then maxR = lr2
If maxC < lc2 Then maxC = lc2
DiffCount = 0
For c = 1 To maxC
Application.StatusBar = "Comparing cells " & Format(c / maxC,
"0 %") & "..."
For r = 3 To maxR
cf1 = ""
cf2 = ""
On Error Resume Next
cf1 = WorkSheet1.Cells(r, c).FormulaLocal
cf2 = WorkSheet2.Cells(r, c).FormulaLocal
On Error GoTo 0
If cf1 < cf2 Then
DiffCount = DiffCount + 1
Cells(r, c).Formula = cf1 & " < " & cf2
End If
If cf1 = cf2 Then
Cells(r, c).Formula = cf1
End If
Next r
Next c
Application.StatusBar = "Creating Comparison..."
With Range(Cells(1, 1), Cells(maxR, maxC))
.Interior.ColorIndex = 19
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
On Error Resume Next
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
On Error GoTo 0
End With
With Range(Cells(1, 1), Cells(2, maxC))
.Interior.ColorIndex = 4
End With
Range(Cells(1, 1), Cells(maxR, maxC)).Select
For Each MyCell In Selection
If MyCell.Value Like "*<*" Then
MyCell.Interior.ColorIndex = 22
End If
Next
Cells(1, 1).Select
Worksheets("Sheet1").Columns("A:Z").AutoFit
Worksheets("Sheet2").Columns("A:Z").AutoFit
Worksheets("Sheet3").Columns("A:Z").AutoFit
Set rptWB = Nothing
Application.StatusBar = False
Application.ScreenUpdating = True
MsgBox DiffCount & " cells contain different values!",
vbInformation, _
"Compare " & WorkSheet1.Name & " with " & WorkSheet2.Name
Sheets("Sheet3").Activate
End Sub