VBA Characters.Delete string over 255 characters

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

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

Worth noting that if your cell content might contain the vbCrLf character combination, then the Characters collection will not "see" the first vbCr character, only the vbLf, and Characters(1).Text will be [# of vbCrLf] shorter than the cell .Value property and things will get out of whack. "Standalone" vbCr are not a problem - this only occurs when vbCr is immediately followed by vbLf.

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`
' Optimized performance by applying properties to runs of characters
'   which share the same font property value
Sub ApplyCharMap(c As Range, map)
    Dim i, t, p, pNum As Long, v, prop, vCurr, start As Long, rl As Long
    t = Timer
    p = FontProps()
    
    Application.ScreenUpdating = False
    For pNum = 1 To UBound(p) + 1 'loop properties
        prop = p(pNum - 1)        'property name
        vCurr = Empty
        rl = 0
        For i = 1 To Len(c.Value)
            v = map(i, pNum)          'property value
            If v <> vCurr Then        'change in value?
                'previous run to apply?
                If rl > 0 Then CallByName c.Characters(start, rl).Font, prop, VbLet, vCurr
                vCurr = v 'reset propery value, start pos, and run length
                start = i
                rl = 1
            Else
                rl = rl + 1
            End If
        Next i
        'apply remaining run?
        If rl > 0 Then CallByName c.Characters(start, rl).Font, prop, VbLet, vCurr
    Next pNum
    
    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
'Optimize performance by:
'   (1) checking properties at the cell-level for non-null values
'   (2) checking "chunks" of characters where cell-level is Null (mixed format)
Function CharMap(c As Range)
    Const CHUNK As Long = 10
    Dim map, i, t, p, pNum, defProps, prop, txt, chars As Characters, v, r As Long, ub As Long
    
    t = Timer
    p = FontProps()
    ub = Len(c.Value)
    ReDim map(1 To ub, 1 To UBound(p) + 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) Step CHUNK
        'Debug.Print i
        Set chars = c.Characters(i, CHUNK)
        For pNum = 1 To UBound(p)
            prop = p(pNum - 1)
            v = defProps(pNum)
            'cell-level prop value is null, so check the chunk
            If IsNull(v) Then v = CallByName(chars.Font, prop, VbGet)
            
            'fill this part of the output array
            For r = i To i + (CHUNK - 1)
                If r > ub Then Exit For
                If Not IsNull(v) Then
                    map(r, pNum) = v 'same for all chars in this chunk
                Else
                    'mixed within chunk - read individually
                    map(r, pNum) = CallByName(c.Characters(r, 1).Font, prop, VbGet)
                End If
            Next r
        Next pNum
    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):