Макрос Excel поиска и вставки

Option Explicit

Function StrSplitProcProc(ByVal StrText As String, ByVal InsText As String) As String
    Dim i As Integer ' для подсчёта пробелов
    Dim L As Integer ' длина строки StrText
    Dim p As Integer ' позиция очередного пробела
    Dim p1 As Integer ' позиция предыдущего пробела
    Dim li As Integer ' длина InsText

    li = Len(InsText)
    L = Len(StrText)
    i = 0
    p1 = 1
    i = 0
    Do
        p = InStr(p1, StrText, " ") ' ищем очередной пробел
        If p = 0 Then Exit Do
        p1 = p + 1
        i = i + 1
        If i >= 5 Then ' каждый пятый меняем на требуемую строку
            StrText = Left(StrText, p - 1) & InsText & Mid(StrText, p + 1, L)
            p1 = p1 + li ' не забываем, что строка уменьшилась на один симвоол (пробел) и удлинилась на длину вставляемого фрагмента
            i = 0
        End If
    Loop
    StrSplitProcProc = StrText
End Function

Function StrSplitProc(ByVal CellText As String, ByVal InsText As String) As String
    Dim L As Integer ' длина строки
    Dim q1 As Integer ' текущая найденная позиция символа переноса строки
    Dim qL As Integer ' найденная позиция символа LF
    Dim qC As Integer ' найденная позиция символа CR
    Dim q0 As Integer ' найденная позиция символа CR или LF
    Dim s1 As String  ' кусочек текста -- текушая строка
    Dim s2 As String  ' сюда пишем обработанный текст
    Dim last As Boolean ' когда символов новой строки больше не будет -- значит, последняя строка

    q1 = 0
    last = False
    L = Len(CellText)
    s2 = ""
    Do
        qL = InStr(q1 + 1, CellText, vbLf)
        qC = InStr(q1 + 1, CellText, vbCr)
        ' Все эти ифы дальше -- что первым нашли (CR или LF) -- то и запоминаем; ничего не нашли -- запоминаем длину строки
        ' А потом обрубаем текст до запомненной позиции
        If qL = 0 And qC = 0 Then
            s1 = CellText
            last = True
            q0 = L
        ElseIf qL > 0 And qC = 0 Then
            q0 = qL
        ElseIf qL = 0 And qC > 0 Then
            q0 = qC
        ElseIf qL > qC Then
            q0 = qC
        Else
            q0 = qL
        End If
        Do While q0 < L And InStr(vbCrLf, Mid(CellText, q0 + 1, 1)) > 0 ' CR и LF не теряем!
            q0 = q0 + 1
        Loop

        s1 = Mid(CellText, q1 + 1, q0 - q1)
        s2 = s2 & StrSplitProcProc(s1, InsText) ' меняем пробелы на то, что нам нужно, и пишем в результирующую строку
        q1 = q0
    Loop Until last
    StrSplitProc = s2
 End Function

Sub StrSplit(ByVal RowBegin As Integer, ByVal RowEnd As Integer, ByVal ColBegin As Integer)
    Dim CurrentCell As Range
    Dim i As Integer


    For i = RowBegin To RowEnd
        Set CurrentCell = ActiveSheet.Cells(i, ColBegin)
        CurrentCell.Value = StrSplitProc(CurrentCell.Value, "<<>>")
    Next i
End Sub