Improve redline comparison of cells

Question

I am using Excel 2010.

I have some working VBA code that compares two cells (from text, to text) and generates the redlined text into a third cell with strikethroughs on removed words, underlines on added words. This is not a straight combination of the contents of the cells.

The code works, but I think it can be more efficient with the use of multidimensional arrays to store things instead of using additional cells and recombining. But I am stuck on how to implement it. I would also like to determine where the breaking point is, especially for newer versions of Excel that I don't have yet, since the number of characters allowed in a cell seems to continually grow with every new release.

Comments are also welcome.

The working code:

Sub main()
  Cells(3, 3).Clear
  Call Redline(3)
End Sub

Sub Redline(ByVal r As Long)
  Dim t As String
  Dim t1() As String
  Dim t2() As String
  Dim i As Integer
  Dim j As Integer
  Dim f As Boolean
  Dim c As Integer
  Dim wf As Integer
  Dim ss As Integer
  Application.ScreenUpdating = False
  t1 = Split(Range("A" + CStr(r)).Value, " ", -1, vbTextCompare)
  t2 = Split(Range("B" + CStr(r)).Value, " ", -1, vbTextCompare)
  t = ""
  f = False
  c = 4
  ss = 0
  If (Range("A" + CStr(r)).Value <> "") Then
    If (Range("B" + CStr(r)).Value <> "") Then
      j = 1
      For i = LBound(t1) To UBound(t1)
        f = False
        For j = ss To UBound(t2)
          If (t1(i) = t2(j)) Then
            f = True
            wf = j
            Exit For
          End If
        Next j
        If (Not f) Then
          Cells(r, c).Value = t1(i)
          Cells(r, c).Font.Strikethrough = True ' strikethrough this cell
          c = c + 1
        Else
          If (wf = i) Then
            Cells(r, c).Value = t1(i) ' aka t2(wf)
            c = c + 1
            ss = i + 1
          ElseIf (wf > i) Then
            For j = ss To wf - 1
              Cells(r, c).Value = t2(j)
              Cells(r, c).Font.Underline = xlUnderlineStyleSingle ' underline this cell
              c = c + 1
            Next j
            Cells(r, c).Value = t1(i)
            c = c + 1
            ss = wf + 1
          End If
        End If
      Next i
      If (UBound(t2) > UBound(t1)) Then
        For i = ss To UBound(t2)
          Cells(r, c).Value = t2(i)
          Cells(r, c).Font.Underline = xlUnderlineStyleSingle ' underline this cell
          c = c + 1
        Next i
      End If
    Else
      t = Range("A" + CStr(r)).Value
    End If
  Else
    t = Range("B" + CStr(r)).Value
  End If
  lc = Range("XFD" + CStr(r)).End(xlToLeft).Column
  Call Merge_Cells(r, 4, lc)
  Application.ScreenUpdating = True
End Sub

Sub Merge_Cells(ByVal r As Long, ByVal fc As Integer, ByVal lc As Long)
  Dim i As Integer, c As Integer, j As Integer
  Dim rngFrom As Range
  Dim rngTo As Range
  Dim lenFrom As Integer
  Dim lenTo As Integer
  Set rngTo = Cells(r, 3)
  ' copy the text over
  For c = fc To lc
    lenTo = rngTo.Characters.Count
    Set rngFrom = Cells(r, c)
    lenFrom = rngFrom.Characters.Count
    If (c = lc) Then
      rngTo.Value = rngTo.Text & rngFrom.Text
    Else
      rngTo.Value = rngTo.Text & rngFrom.Text & " "
    End If
  Next c
  ' now copy the formatting
  j = 0
  For c = fc To lc
    Set rngFrom = Cells(r, c)
    lenFrom = rngFrom.Characters.Count + 1 ' add one for the space after each word
    For i = 1 To lenFrom - 1
      With rngTo.Characters(j + i, 1).Font
        .Name = rngFrom.Characters(i, 1).Font.Name
        .Underline = rngFrom.Characters(i, 1).Font.Underline
        .Strikethrough = rngFrom.Characters(i, 1).Font.Strikethrough
        .Bold = rngFrom.Characters(i, 1).Font.Bold
        .Size = rngFrom.Characters(i, 1).Font.Size
        .ColorIndex = rngFrom.Characters(i, 1).Font.ColorIndex
      End With
    Next i
    j = j + lenFrom
  Next c
  ' wipe out the temporary columns
  For c = fc To lc
    Cells(r, c).Clear
  Next c
End Sub

Answer 1

You can directly assign Excel Range object to VBA 2d-array and perform all that business logic operations on that array. It will provide substantial performance boost vs range iteration. The result values then can be inserted back into Excel worksheet column from that 2d-array.

Sample code snippet follows:

Sub Range2Array()
    Dim arr As Variant
    arr = Range("A:B").Value
    'alternatively
     'arr = Range("A:B")
    'test
    Debug.Print (arr(1, 1))
End Sub

Another useful technique is to assign Excel's UsedRange to VBA Array:

arr = ActiveSheet.UsedRange

Hope this may help. Best regards,

Answer 2

Sample code not quite right

I've got a spreadsheet with the following "original" and "changed" content:

• Tesla to Begin Trial for Allowing Other Vehicles from Other Electric Vehicle Automakers to Use Tesla Superchargers
• Tesla to Begin Trial for Allowing Other Vehicles from Other EV Auto Makers to Use Tesla Superchargers

Running your code, I got not-quite-right results.

The "original" text that is missing from the "changed" version is correctly shown with strikethrough, but the new text in the "changed" version is just ... missing.

Alternative approach

Poking around, it looks like you're trying to re-create MS Word's Track Changes formatting.

Why not just leverage Word?

The following VBA code does just that. This requires that your Excel VBA project has a reference to the Word object library. You can add this from within the VBA editor by clicking Tools ? References, and selecting Microsoft Word XX.Y Object Library, where XX.Y is whatever version you have installed.

Public Sub CompareCells()
' ####################
' Basic Flow
'
' 1. Get the text content of the two cells to compare.
' 2. Get an open instance of MS Word, or spin up a new one.
' 3. Use Word's text-comparison features to generate the tracked-changes markup.
' 4. Copy that markup to the clipboard.
' 5. Then just paste that into our target cell.
' ####################
    
    Const Src As String = "A" ' Column containing the original source text
    Const Tgt As String = "B" ' Column containing the targeted text to compare
    Const Cmp As String = "C" ' Column where we will put the marked-up comparison
    Const RowToUse As Integer = 8 ' Rejigger as appropriate to your use case.
    
    ' 1.
    Dim ThisSheet As Excel.Worksheet: Set ThisSheet = Excel.ActiveSheet
    Dim StrSrc As String, StrTgt As String
    StrSrc = ThisSheet.Range(Src & RowToUse).Value
    StrTgt = ThisSheet.Range(Tgt & RowToUse).Value
    
    ' 2.
    Dim Wd As Word.Application: Set Wd = GetApp("Word")
    
    ' 3.
    Dim DocOrig As Word.Document, DocChgd As Word.Document, DocMarkup As Word.Document
    Set DocOrig = Wd.Documents.Add(Visible:=False)
    DocOrig.Content = StrSrc
    Set DocChgd = Wd.Documents.Add(Visible:=False)
    DocChgd.Content = StrTgt
    Set DocMarkup = Wd.CompareDocuments(DocOrig, DocChgd, wdCompareDestinationNew)
    
    ' 4.
    DocMarkup.Content.Copy
    
    ' 5.
    ThisSheet.Range(Cmp & RowToUse).Select
    ThisSheet.Paste
    
    ' Cleanup
    DocOrig.Close savechanges:=False
    DocChgd.Close savechanges:=False
    DocMarkup.Close savechanges:=False
End Sub

Public Function GetApp(AppName As String) As Object
    Dim app As Object
    On Error GoTo Handler
        Set app = GetObject(, AppName & ".Application")
        Set GetApp = app
        Exit Function
    On Error GoTo 0
    
Handler:
    If Err.Number > 0 And Err.Number <> 429 Then ' Unknown error, so error out
        Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
        Exit Function
    End If
    
    DoEvents
    
    ' If we get here, there's no open app by that name, so start a new instance.
    Set app = CreateObject(AppName & ".Application")
    Set GetApp = app
End Function

When run using the same sample texts, I get the following:

This time, we get both the removed text in strikethrough, and the added text in underlining, with color coding as well.