Ошибка при разбиении текста на символы (на вход данные из Excel)

Const ИмяФайлаШаблона = "Doc1.2.docx"
' Const КоличествоОбрабатываемыхСтолбцов = 82
Const РасширениеСоздаваемыхФайлов = ".docx"
 
Sub СформироватьДоговоры()
    ПутьШаблона = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, ИмяФайлаШаблона)
    НоваяПапка = NewFolderName & Application.PathSeparator
    Dim row As Range, pi As New ProgressIndicator, FindText() As String, ReplaceText() As String
    r = Cells(Rows.Count, "A").End(xlUp).row: rc = r - 2  ' ???
    If rc < 1 Then MsgBox "Строк для обработки не найдено", vbCritical: Exit Sub
 
    pi.Show "Формирование договоров": pi.ShowPercents = True: s1 = 10: s2 = 90: p = s1: a = (s2 - s1) / rc
    pi.StartNewAction , s1, "Запуск приложения Microsoft Word"
 
    ' Dim WA As Word.Application, WD As Word.Document: Set WA = New Word.Application    ' c подключением библиотеки Word
    Dim WA As Object, WD As Object: Set WA = CreateObject("Word.Application")    ' без подключения библиотеки Word
 
    For Each row In ActiveSheet.Rows("7:" & r)
        With row
            ФИО = Trim$(.Cells(2)) & " " & Trim$(.Cells(3)) & " " & Trim$(.Cells(4))
            Filename = НоваяПапка & ФИО & РасширениеСоздаваемыхФайлов
 
            pi.StartNewAction p, p + a / 3, "Создание нового файла на основании шаблона", ФИО
            Set WD = WA.Documents.Add(ПутьШаблона): DoEvents
 
            pi.StartNewAction p + a / 3, p + a * 2 / 3, "Замена данных ...", ФИО
            For i = 1 To 82
                Select Case i
                    Case 25
                        Call x(Len(Trim$(.Cells(i))), Cells(6, i), Trim$(.Cells(i)), False) ' контрольная информация
                    Case 6, 16
                        Call x(3, Cells(6, i), Trim$(.Cells(i)), True) ' дата
                    Case 31, 41, 51
                        Call x(6, Cells(6, i), Trim$(.Cells(i)), False) ' идексы
                    Case 29, 63, 76
                        Call x(10, Cells(6, i), Trim$(.Cells(i)), False) ' номера телефона
                    Case Else
                        ReDim ReplaceText(0) As String ' для остальных ячеек
                        ReDim FindText(0) As String
                        FindText(0) = "{" + Cells(6, i) + "}": ReplaceText(0) = Trim$(.Cells(i))
                        n = 0
                End Select
                
                ' так почему-то заменяет не всё (не затрагивает таблицу)
                'WA.Selection.Find.Execute FindText, , , , , , , wdFindContinue, False, ReplaceText, True
 
                'pi.line3 = "Заменяется поле " & FindText
                For j = 0 To n ' вставка частей ячейки
                    With WD.Range.Find
                        .Text = FindText(j)
                        .Replacement.Text = ReplaceText(j)
                        .Forward = True
                        .Wrap = 1
                        .Format = False: .MatchCase = False
                        .MatchWholeWord = False
                        .MatchWildcards = False
                        .MatchSoundsLike = False
                        .MatchAllWordForms = False
                        .Execute Replace:=2
                    End With
                    DoEvents
                Next j
            Next i
            pi.StartNewAction p + a * 2 / 3, p + a, "Сохранение файла ...", ФИО, " "
            WD.SaveAs Filename: WD.Close False: DoEvents
            p = p + a
        End With
    Next row
 
    pi.StartNewAction s2, , "Завершение работы приложения Microsoft Word", " ", " "
    WA.Quit False: pi.Hide
    msg = "Сформировано " & rc & " договоров. Все они находятся в папке" & vbNewLine & НоваяПапка
    MsgBox msg, vbInformation, "Готово"
End Sub
 
 
Sub x(ByVal leng As Integer, ByVal mark As String, ByVal volume As String, ByVal d As Boolean)
    If d Then
        ReDim ReplaceText(2) As String: ReplaceText() = Split(vol, ".")
    Else: ReDim ReplaceText(0 To Len(vol) - 1) As String: ReplaceText() = volume.ToCharArray
    End If
    ReDim FindText(leng - 1) As String
    For j = 1 To leng
        FindText(j) = "{" + mark + j + "}"
    Next j
    n = leng - 1
End Sub
 
 
 
Function NewFolderName() As String
    NewFolderName = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, "Договоры, сформированные " & Get_Now)
    MkDir NewFolderName
End Function
 
Function Get_Date() As String: Get_Date = Replace(Replace(DateValue(Now), "/", "-"), ".", "-"): End Function
Function Get_Time() As String: Get_Time = Replace(TimeValue(Now), ":", "-"): End Function
Function Get_Now() As String: Get_Now = Get_Date & " в " & Get_Time: End Function