Sub Underline(c As Range, diffs As String)     Dim a, i     a = Split(diffs, ",")     For i = LBound(a) To UBound(a)         If IsNumeric(a(i)) Then             c.Characters(a(i), 1).Font.Underline = True         End If     Next End Sub  Public Function FindDiffs(ByVal sSheet As String, ByVal sBuffer As String, Optional ByVal lStart As Long = 0, _                            Optional ByVal lEnd As Long) As String      'This function takes 2 strings, and returns an array of character positions that in sSheet that are     'to be marked as changes from the second string.  Return is in the form of a comma delimited string,     'so if no changes are found, splitting the return will not let a LBound - UBound loop execute.  This     'function calls itself recursively.  lStart is the absolute starting position of the sheet substring     'that is passed to it, and lEnd is the absolute ending position of the substring.      Dim sFound As String, sOut As String, lReturn As Long, lFindLen As Long, lPos As Long, lRemoved As Long     Dim sSplitS() As String, sSplitB() As String, lIndex As Long, lStartLen As Long, lTemp As Long          On Error GoTo ErrHand              If lStart = 0 Then lStart = 1                                           'This will only be true on the first pass.     If lEnd = 0 Then lEnd = Len(sSheet)                                     'Ditto.          If Len(sBuffer) = 0 Then                                                'If there is nothing in the buffer,         FindDiffs = MarkSubstring(lStart, lEnd)                             'Just return the entire sheet string.         Exit Function                                                       'And exit.     End If      lReturn = RightStrip(sSheet, sBuffer)                                   'Strip off all matches on the right.     lEnd = lEnd - lReturn                                                   'Decrease the end by the number removed.     lReturn = LeftStrip(sSheet, sBuffer)                                    'Strip off all the matches on the left.     lStart = lStart + lReturn                                               'Increase the start by the number removed.                                                                  If Len(sSheet) <> 0 Then                                                'Check to see if there are unmatched chars.         If Len(sBuffer) <> 0 Then                                           'See if anything in left in the buffer.             sFound = SeekMatch(sSheet, sBuffer)                             'Get the longest matching substring.             If Len(sFound) <> 0 Then                                        'Make sure a match was returned.                 lReturn = InStr(1, sSheet, sFound) - 1                      'Find out where it is in the sheet string.                 lRemoved = Len(sFound)                                      'See how long it is.                                  sSplitS = Split(sSheet, sFound)                             'Split the string using it as a delimiter.                 sSplitB = Split(sBuffer, sFound)                            'Split the buffer the same way.                                  If UBound(sSplitS) = 1 And UBound(sSplitB) = 1 Then         'Error check, should always return true.                     lTemp = lStart + lReturn - 1                            'Recalculate the end position for the left.                     sOut = sOut & FindDiffs(sSplitS(0), sSplitB(0), lStart, lTemp)  'Recursive call for the left half.                     lTemp = lStart + lReturn + lRemoved                     'Recalculate the start position for the right.                     sOut = sOut & FindDiffs(sSplitS(1), sSplitB(1), lTemp, lEnd)    'Recursive call for the right half.                 End If             Else                 sOut = sOut & "," & MarkSubstring(lStart, lStart + Len(sSheet) - 1) 'No match, so mark everything left.             End If         Else             sOut = sOut & "," & MarkSubstring(lStart, lStart + Len(sSheet) - 1) 'No buffer left, so mark what's left.         End If     Else         Exit Function                                                       'Nothing left to mark, so exit.     End If      FindDiffs = sOut                                                        'Return the string.  ErrHand:     If Err.Number <> 0 Then                                                 'Check for errors.         Call MsgBox("Error number " & Err.Number & vbCrLf & Err.Description & vbCrLf & _                     "in FindDiffs.", vbCritical)     End If  End Function    Private Function MarkSubstring(lStart As Long, lEnd As Long) As String      'Just a helper function that returns a comma delimited string of numbers between lStart and lEnd.      Dim lPos As Long, sOut As String      On Error GoTo ErrHand      For lPos = lStart To lEnd                                   'Loop between the values.         sOut = sOut & "," & CStr(lPos)                          'flag them as changes.     Next lPos          If Len(sOut) <> 0 Then                                      'Make sure there is output lStart may have been bigger.         MarkSubstring = Right$(sOut, Len(sOut) - 1)             'Strip the comma off the start and return.     End If  ErrHand:     If Err.Number <> 0 Then                                     'Check for errors.         Call MsgBox("Error number " & Err.Number & vbCrLf & Err.Description & vbCrLf & _                     "in MarkSubstring.", vbCritical)     End If  End Function  Private Function LeftStrip(ByRef sSheet As String, ByRef sBuffer As String) As Long      'This function starts from the left of each string and strips off all characters that match.  The     'return value is the number of characters removed from each string.      Dim sTest1 As String, sTest2 As String, lCount As Long      On Error GoTo ErrHand      Do                                                      'Loop until the test characters no longer match.         sTest1 = Left$(sSheet, 1)                           'Get the first character from the first string.         sTest2 = Left$(sBuffer, 1)                          'Get the first character from the second string.         If sTest1 = sTest2 Then                             'If they are the same...             lCount = lCount + 1             sSheet = Right$(sSheet, Len(sSheet) - 1)        'Strip them off both strings.             sBuffer = Right$(sBuffer, Len(sBuffer) - 1)         Else             Exit Do                                         'If they are different, we can exit the loop.         End If         If Len(sSheet) = 0 Or Len(sBuffer) = 0 Then Exit Do 'Stop stripping characters if there is nothing in one.     Loop      LeftStrip = lCount                                      'Return the removed count.  ErrHand:     If Err.Number <> 0 Then                                 'Check for errors.         Call MsgBox("Error number " & Err.Number & vbCrLf & Err.Description & vbCrLf & _                     "in LeftStrip.", vbCritical)     End If  End Function  Private Function RightStrip(ByRef sSheet As String, ByRef sBuffer As String) As Long      'This function starts from the right of each string and strips off all characters that match.  The     'return value is the number of characters removed from each string.      Dim sTest1 As String, sTest2 As String, lCount As Long      On Error GoTo ErrHand      Do                                                      'Loop until the test characters no longer match.         sTest1 = Right$(sSheet, 1)                          'Get the last character from the first string.         sTest2 = Right$(sBuffer, 1)                         'Get the last character from the second string.         If sTest1 = sTest2 Then                             'If they are the same...             lCount = lCount + 1             sSheet = Left$(sSheet, Len(sSheet) - 1)         'Strip them off both strings.             sBuffer = Left$(sBuffer, Len(sBuffer) - 1)         Else             Exit Do                                         'If they are different, we can exit the loop.         End If         If Len(sSheet) = 0 Or Len(sBuffer) = 0 Then Exit Do 'Stop stripping characters if there is nothing in one.     Loop      RightStrip = lCount                                     'Return the removed count.  ErrHand:     If Err.Number <> 0 Then                                 'Check for errors.         Call MsgBox("Error number " & Err.Number & vbCrLf & Err.Description & vbCrLf & _                     "in RightStrip.", vbCritical)     End If  End Function  Private Function SeekMatch(ByVal sSheet As String, ByVal sBuffer As String) As String      'This function finds the longest matching substring of sBuffer that exists in sSheet, and returns it.     'If no matches are found, it returns a null string.      Dim sTest As String, lOuter As Long, lInner As Long, lResult As Long, lLength As Long, lLast As Long     Dim sFound As String          On Error GoTo ErrHand          sTest = sBuffer                                         'Set the initial test string for the loops.          For lOuter = Len(sBuffer) To 1 Step -1                  'Loop through all lengths of the buffer string.         For lInner = 1 To Len(sBuffer) - lOuter             'Loop through all lengths of the substring.             sTest = Mid$(sBuffer, lOuter, lInner)           'Get the substring from the Buffer string.             lResult = InStr(1, sSheet, sTest)               'Find out if it is in the Sheet string.             If lResult <> 0 Then                            'If there is a match,                 lLength = Len(sTest)                        'See how long it is.                 If lLength > lLast Then                     'If it's longer than the last match,                     sFound = sTest                          'Update the match holder.                     lLast = lLength                         'Update the last length holder.                 End If             End If         Next lInner     Next lOuter      SeekMatch = sFound                                      'Return the longest matching substring.  ErrHand:     If Err.Number <> 0 Then                                 'Check for errors.         Call MsgBox("Error number " & Err.Number & vbCrLf & Err.Description & vbCrLf & _                     "in SeekMatch.", vbCritical)     End If      End Function 

Option Explicit  Dim oldValue As String Dim oldTarget As Range  Private Sub Worksheet_Activate() On Error Resume Next     If Not IsError(ActiveCell) Then oldValue = ActiveCell.Value Else oldValue = ""     Set oldTarget = ActiveCell End Sub  Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next     Dim diffs As String     If Target.Cells.Count = 1 Then         If Target = oldTarget Then             If Not IsError(Target) Then                 If oldValue <> Target.Value Then                     diffs = FindDiffs(Target.Value, oldValue)                     Underline Target, diffs                 End If             End If         End If     End If End Sub  Private Sub Worksheet_SelectionChange(ByVal Target As Range) On Error Resume Next     If Target.Cells.Count = 1 Then         If Not IsError(Target) Then oldValue = Target.Value Else oldValue = ""         Set oldTarget = Target     End If End Sub