VBA Characters.Delete string over 255 characters

Question

I want to delete parts of a string that is over 255 characters, while keeping the formatting in the cell the same. The question is related to this - the answer provided doesn't cover text that is over 255 characters, but since the issue is stand-alone, I think it merits its own question.

For demonstrative purposes, I want to delete 'lobortis' from the end of following text.

Lorem ipsum dolor sit amet, consectetur adipiscing elit. Etiam vulputate tellus enim, at sagittis felis lobortis at. Sed porttitor porttitor congue. Integer a ornare ante. Mauris a pellentesque tortor, non malesuada mauris. Duis rutrum lectus vitae lobortis non matrum 

Here's the code that does the trick for text less than 255 characters.

Is there a way to do this for text that is over 255 characters?

Sub ModifyTextSingleV2()
    Dim ws As Worksheet
    Dim cell As Range
    ' Define worksheet
    Set ws = Workbooks("workbook1").Sheets("Sheet1")
    
    ' The cell where the text is
    Set cell = ws.Cells(1, 1)
    
    ' Delete 'non matrum' from the cell << doesn't work, but would work if it were below 255 characters.
    cell.Characters(259, 10).Delete
End Sub

Answer 1

Spent far to long getting this right so I though I'd add it here:

Option Explicit

Sub tester()
    
    Dim ws As Worksheet, c As Range
    
    Set ws = ThisWorkbook.Worksheets("Formatting")
    Set c = ws.Range("A1")
    
    ws.Range("A8").Copy c  'copy from source cell (for testing only)
    ReplaceInFormattedCell c, "lobortis", ""
    Stop 'review and F5 to continue...
    
    ws.Range("A8").Copy c  
    ReplaceInFormattedCell c, "lobortis", "lobo"
    Stop
    
    ws.Range("A8").Copy c  
    ReplaceInFormattedCell c, "lobortis", "lobolobolobolobo"
    Stop
    
End Sub

Sub ReplaceInFormattedCell(c As Range, wd As String, wdRep As String)
    Dim map, txt, pos As Long, wdLen As Long, wdRepLen As Long, found As Boolean
    
    wdLen = Len(wd)
    wdRepLen = Len(wdRep)
    pos = InStr(1, c.Value, wd, vbTextCompare)
    Do While pos > 0
        found = True
        Debug.Print "Found at:", pos
        If IsEmpty(map) Then map = CharMap(c) 'need to create formatting map?
        txt = c.Value
        c.Value = Left(txt, pos - 1) & wdRep & Mid(txt, pos + wdLen, Len(txt))
        AdjustFontMap map, pos, wdLen, wdRepLen 'adjust map to reflect changes to cell content
        pos = InStr(pos + wdLen, c.Value, wd, vbTextCompare)
    Loop
    If found Then ApplyCharMap c, map 'apply map if we made any changes

End Sub

'apply a font properties mapping array to cell `c`
Sub ApplyCharMap(c As Range, map)
    Dim i, t, p, pNum As Long, v, prop
    t = Timer
    p = FontProps()
    Application.ScreenUpdating = False
    For i = 1 To Len(c.Value)
        With c.Characters(i, 1)
            For pNum = 1 To UBound(p) + 1 'loop properties
                prop = p(pNum - 1)        'property name
                v = map(i, pNum)          'property value
                CallByName c.Characters(i, 1).Font, prop, VbLet, v
            Next pNum
        End With
    Next i
    Application.ScreenUpdating = True
    Debug.Print "Applied map in", Timer - t
End Sub

'Map font properties per-character for cell `c` and return as
' a 2D array
'Optimixed to skip per-character checks if a property is the same
' for the whole content.
Function CharMap(c As Range)
    Dim map, i, t, p, pNum, defProps, prop
    t = Timer
    p = FontProps()
    ReDim map(1 To Len(c.Value), 1 To UBound(FontProps) + 1)
    
    ReDim defProps(1 To UBound(p) + 1)
    For pNum = 1 To UBound(p) + 1 'check all font properties at the cell level
        prop = p(pNum - 1)
        defProps(pNum) = CallByName(c.Font, prop, VbGet)
    Next pNum
    
    For i = 1 To Len(c.Value)
        With c.Characters(i, 1)
            For pNum = 1 To UBound(p)
                prop = p(pNum - 1)
                If IsNull(defProps(pNum)) Then 'mixed values in cell?
                    map(i, pNum) = CallByName(.Font, prop, VbGet)
                Else
                    map(i, pNum) = defProps(pNum) 'all same value for cell...
                End If
            Next pNum
        End With
    Next i
    Debug.Print "Created map in", Timer - t
    CharMap = map
End Function

'font properties to track
Function FontProps()
    FontProps = Array("Bold", "Italic", "Underline", "Strikethrough", _
                      "Size", "Color", "Name")
End Function

'Adjust 2D array font character mapp to account for replacing a word at a specified location
'   map      = 2D array of character font properties
'   startPos = row where first character in search word was found
'   wdLen    = length of search word
'   repLen   = length of replacement word
Sub AdjustFontMap(ByRef map, startPos As Long, wdLen As Long, repLen As Long)
    Dim newMap, ub As Long, ubNew As Long, n As Long, i As Long, r As Long
    Dim iNew As Long, diff As Long, adding As Boolean, editPos As Long
    
    diff = repLen - wdLen     '# of rows to add (diff>0) or remove (diff<0)
    If diff = 0 Then Exit Sub 'no work to do....
    
    ub = UBound(map, 1) 'current size
    ubNew = ub + diff   'new size
    adding = diff > 0     'adding row (or removing)
    editPos = IIf(adding, startPos + wdLen, startPos + repLen) 'changes begin here
    
    ReDim newMap(1 To ubNew, 1 To UBound(map, 2)) 'size output array
    
    For r = 1 To editPos - 1 'before any changes
        CopyRow map, r, newMap, r
    Next r
    
    i = editPos
    iNew = editPos
    'handle changes
    For n = 1 To Abs(diff)
        If adding Then
            CopyRow newMap, iNew - 1, newMap, iNew 'copy previous row
            iNew = iNew + 1
        Else
            i = i + 1   'removing, so just increment row index
        End If
    Next n
    
    For r = iNew To ubNew 'rest of rows
        CopyRow map, i, newMap, r
        i = i + 1
    Next r
    map = newMap 're-assign reference
End Sub

'copy a row from one 2D array to another (or to the same array)
Sub CopyRow(arrSrc, rwSrc As Long, arrDest, rwDest As Long)
    Dim c As Long
    For c = 1 To UBound(arrSrc, 2)
        arrDest(rwDest, c) = arrSrc(rwSrc, c)
    Next c
End Sub

My source cell (A8 in Sub tester):