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

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

volume.ToCharArray '''- так можно писать, если volume - объект, а ToCharArray - метод объекта

'...
Dim Arr() As String
      n%=Len(Stri$)
      Redim Arr(1 to n) As String
      for i%=1 to n%
          Arr(i%)=mid$(Stri$,i%,1)
      Next i%
'...

FindText(j) = "{" + mark + j + "}"

FindText(j) = "{" & Cstr(mark) & Cstr(j) & "}"

Const ИмяФайлаШаблона = "Doc1.2.docx"
' Const КоличествоОбрабатываемыхСтолбцов = 82
Const РасширениеСоздаваемыхФайлов = ".docx"
 
Dim RepalceText() as String
Dim FindText() as String
 
' далее - по коду

For u% = 1 To Len(volume) - 1
            ReplaceText(u) = Mid$(volume, u%, 1)
Next u%

Const NewFileType = ".doc"
Dim FindText() As String, ReplaceText() As String, n As Integer
 
 
Sub СформироватьДоговоры()
    Dim row As Range, pi As New ProgressIndicator
    ReDim ReplaceText(1 To 100) As String
    ReDim FindText(1 To 30) As String
    r = Cells(Rows.Count, "A").End(xlUp).row: rc = r - 2
    If rc < 1 Then MsgBox "Строк для обработки не найдено", vbCritical: Exit Sub
    
    CardType = Cells(2, 2)
    Select Case CardType
        Case "Сбербанк-Maestro", "Сбербанк-Visa Electron"
            TemplateFName = "Doc2.doc"
        Case "Gold Mastercard", "Visa Gold", "Visa Gold Аэрофлот", "Visa Gold " & Chr(34) & "Подари жизнь" & Chr(34)
            TemplateFName = "Doc3.doc"
        Case Else
            TemplateFName = "Doc1.doc"
    End Select
    
    TemplateDir = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, TemplateFName)
    NewFolder = NewFolderName & Application.PathSeparator
    
    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
            FIO = Trim$(.Cells(2)) & " " & Trim$(.Cells(3)) & " " & Trim$(.Cells(4))
            Filename = NewFolder & FIO & NewFileType
 
            pi.StartNewAction p, p + a / 3, "Создание нового файла на основании шаблона", FIO
            Set WD = WA.Documents.Add(TemplateDir): DoEvents
 
            pi.StartNewAction p + a / 3, p + a * 2 / 3, "Замена данных ...", FIO
            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
                        FindText(1) = "{" + Cells(6, i) + "}": ReplaceText(1) = Trim$(.Cells(i))
                        n = 1
                End Select
                
                ' так почему-то заменяет не всё (не затрагивает таблицу)
                'WA.Selection.Find.Execute FindText, , , , , , , wdFindContinue, False, ReplaceText, True
 
                'pi.line3 = "Заменяется поле " & FindText
 
                For j = 1 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, "Сохранение файла ...", FIO, " "
            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 & NewFolder
    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
        ReplaceText() = Split(volume, ".", 3)
    Else
        For u% = 1 To Len(volume)
            ReplaceText(u%) = Mid$(volume, u%, 1)
            'asd = Mid$(volume, u%, 1)
            'MsgBox asd, vbInformation, "Готово"
        Next u%
    End If
    
    'ReDim FindText(1 To leng) As String
    For j = 1 To leng
        FindText(j) = "{" & CStr(mark) & CStr(j) & "}"
    Next j
    n = leng
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