Characters.Insert Method

[rmweaver81]

I have created a "track changes" script that more closely resembles the way is performed in MS Word. It accomplishes this by walking through each word of an edited text and compares it to the words in a base text. The result of the comparison is then placed into a result cell using the characters.insert method. As I am running through the script, the result cell stops increasing in length once the cell reaches 255 characters even though I have confirmed that the script is still performing the word comparisons until it reaches the end of the edited and base texts. If the characters.insert method only allows 255 chacters in a cell, does any one have any recommendation for how to fix this issue? The code and file are provided below

Sub TrackChanges()

Dim edit, base As String
Dim editWord, baseWord As String
Dim editLength, baseLength As Integer
Dim editIndex, baseIndex, resultIndex As Integer
Dim prevEditIndex, prevBaseIndex As Integer
Dim wordLength As Integer


'Set the result index to startat 1
resultIndex = 1
baseIndex = 1
editIndex = 1


'Set text of edit and base variables
edit = Cells(3, 2)
base = Cells(4, 2)


'validate need to continue
If (edit = "" Or IsEmpty(edit) = True) And (base = "" Or IsEmpty(base) = True) Then
    Exit Sub
End If


'Set total length of edit and base text
editLength = Len(edit)
baseLength = Len(base)


'walks through the edit and base text strings, comparing them for differences
'and placing the resulting formatted text in the result field
Do
    'get the next word from the edit and base text string
    editWord = GetWord(edit, editIndex, editLength, False)
    baseWord = GetWord(base, baseIndex, baseLength, False)
    
    'If the words don't match, pull a longer part of the edit text for comparison
    'to the remaining string of the base text
    If editWord <> baseWord Then
        editWordPlus = GetWord(edit, editIndex, editLength, True)
    End If
    
    'if the words are the same...
    If editWord = baseWord Then
        'set the previous index point (prior to this new word), get the new
        'index point (for both the edit and base text), and determine the new word length by
        'subtracting the index point from the previous index point
        prevEditIndex = editIndex
        editIndex = GetIndex(edit, editIndex, editLength)
        baseIndex = GetIndex(base, baseIndex, baseLength)
        wordLength = editIndex - prevEditIndex
        
        'Select the result cell
        Cells(5, 2).Select
        
        'with that cell, append the edit word to any existing characters in the result
        'string and set the specified formatting for the new word
        With ActiveCell
            .Characters(Len(.Value) + 1).Insert editWord
            .Characters(Start:=resultIndex, length:=wordLength).Font.Strikethrough = False
            .Characters(Start:=resultIndex, length:=wordLength).Font.Color = -16777216
        End With
    
    'Or else, if the edit word is found later in the base text, then the current base
    'word must have been deleted from the edited text
    ElseIf InStr(baseIndex, base, editWordPlus, vbBinaryCompare) <> 0 Then
        'set the previous index point (prior to this new word), get the new
        'index point (for only the base text), and determine the new word length by
        'subtracting the index point from the previous index point
        prevBaseIndex = baseIndex
        baseIndex = GetIndex(base, baseIndex, baseLength)
        wordLength = baseIndex - prevBaseIndex
        
        'Select the result cell
        Cells(5, 2).Select
        
        'with that cell, append the base word to any existing characters in the result
        'string and set the specified formatting for the new word
        With ActiveCell
            .Characters(Len(.Value) + 1).Insert baseWord
            .Characters(Start:=resultIndex, length:=wordLength).Font.Strikethrough = True
            .Characters(Start:=resultIndex, length:=wordLength).Font.Color = -16776961
        End With
    
    'Or else, the remaining option is that the edit word was added to the base text
    Else:
        'set the previous index point (prior to this new word), get the new
        'index point (for only the edit text), and determine the new word length by
        'subtracting the index point from the previous index point
        prevEditIndex = editIndex
        editIndex = GetIndex(edit, editIndex, editLength)
        wordLength = editIndex - prevEditIndex
        
        'Select the result cell
        Cells(5, 2).Select
        
        'with that cell, append the edit word to any existing characters in the result
        'string and set the specified formatting for the new word
        With ActiveCell
            .Characters(Len(.Value) + 1).Insert editWord
            .Characters(Start:=resultIndex, length:=wordLength).Font.Strikethrough = False
            .Characters(Start:=resultIndex, length:=wordLength).Font.Color = -65536
        End With
    End If
    
    'advance the result index by the length of the word
    resultIndex = resultIndex + wordLength
    
Loop Until (editIndex = editLength + 1 And baseIndex = baseLength + 1)


End Sub
'Gets a word from the supplied string and returns it to the calling subroutine
Function GetWord(ByVal Str As String, ByVal startIndex As Integer, ByVal lastChar As Integer, _
ByVal wordPlus As Boolean) As String


'Set the end index equal to the input start index (enables you to ignore spaces between words you
'have already processed
endIndex = startIndex
    
    'keep adding to the end index value until you hit a space or the last character of the
    'supplied string
    Do
        endIndex = endIndex + 1
    Loop Until (Mid(Str, endIndex, 1) = " " Or endIndex >= lastChar)


'extract the word from the supplied string using the start index and the length of the word
'return this word to the main subroutine
If wordPlus = False Then
    GetWord = Mid(Str, startIndex, endIndex - startIndex + 1)
Else
    GetWord = Mid(Str, startIndex, endIndex - startIndex + 20)
End If


End Function
'Get the index point from the supplied string and returns the value to the calling subroutine
Function GetIndex(ByVal Str As String, ByVal startIndex As Integer, ByVal lastChar As Integer) As Integer


'Set the end index equal to the input start index (enables you to ignore spaces between words you
'have already processed
endIndex = startIndex
    
    'keep adding to the end index value until you hit a space or the last character of the
    'supplied string
    Do
        endIndex = endIndex + 1
    Loop Until (Mid(Str, endIndex, 1) = " " Or endIndex >= lastChar)
    
'set your index point equal to your end index, which is either a space or the last character
'in the supplied string.  Return this variable to the main subroutine.
GetIndex = endIndex + 1
    
End Function

http://www.filedropper.com/trackchangesissue