Improve redline comparison of cells - vba

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.