For i = 1 To UBound(xF)
    n = Calc_NR(dicNum, xF(i, 1) & "|" & xF(i, 4))
    dicData.Item(Join(Array(n, xF(i, 6), xF(i, 3)), "|")) = xF(i, 2)
 Next i

Function Calc_NR(dicNum As Object, key As String) As Long 'расчет нумерации реестра
    If dicNum.Exists(key) Then
        Calc_NR = Calc_NR + 1
    Else
        dicNum.Item(key) = 1: Calc_NR = 1
    End If
End Function

dicData.Item(Join(Array(n, xF(i, 6)...

dicData.Item(Join(Array(Calc_NR, xF(i, 6)...

                    For Each att In dicMail.Item(k)
                        .AddAttachment ThisWorkbook.Path & "\" & att
                        Kill ThisWorkbook.Path & "\" & att
                    Next att

        For i = 1 To 2
            If Not dicMail.Exists(Key) Then
                dicMail.Item(Key) = Cells(i, 1).Value & ".pdf"
            Else:
                dicMail.Item(Key) = Array(dicMail.Item(Key), Cells(i, 1).Value & ".pdf")
            End If
        Next i
ad = Func_SendMailCDO(dicMail)

Function Func_SendMailCDO(dicMail As Object) 'отправка на e-mail покупателя
    Dim objCDOCnf As Object, objCDOMsg As Object, att As Variant, k As Variant
        Const CDO_Cnf = "http://schemas.microsoft.com/cdo/configuration/"
        Set objCDOCnf = CreateObject("CDO.Configuration") 'назначаем конфигурацию CDO
        
            With objCDOCnf.Fields
...
                .Item(CDO_Cnf & "sendusername") = "login@mail.ru" 'учетная запись на сервере
                .Item(CDO_Cnf & "sendpassword") = "pass" 'пароль к почтовому аккаунту
                .Update
            End With
                    
            On Error Resume Next
            For Each k In dicMail.keys
                Set objCDOMsg = CreateObject("CDO.Message") 'создаем сообщение
                With objCDOMsg
...
                    .Subject = "Копии документов" 'тема письма

For Each att In dicMail.Item(k)
         .Attachments.Add ThisWorkbook.Path & "\" & att
         Kill ThisWorkbook.Path & "\" & att
Next att
       .Send

ad= DeclensionFIO(2, CStr(Split([F1])(0)), CStr(Split([F1])(1)), CStr(Split([F1])(2)))

Function DeclensionFIO_Arr(CaseWord As Byte, ParamArray SNP()) As String 
...

ad = DeclensionFIO_Arr(3, Split([F1]))

Function test(CaseWord As Byte, Surname As String, Optional Name As String, Optional Patronymic As String) As String
    tmp = Mid(Array(Surname, Name, Patronymic)(i), 1, Len(Array(Surname, Name, Patronymic)(i)) - 1)
    'склонение фамилии
    t1 = tmp
    i = i + 1
    'склонение имени
    t2 = tmp & 123
End Function

Public Function RegExpExtract(Text As String, Pattern As String, Optional Item As Integer = 1) As String
    On Error GoTo 0
    Set v_RegExp = CreateObject("VBScript.RegExp")
        With v_RegExp
            .Pattern = Pattern
            .Global = True
            If .test(Text) Then Set v_Matches = .Execute(Text): RegExpExtract = v_Matches.Item(Item - 1): Exit Function
        End With
0:
        RegExpExtract = CStr(CVErr(xlErrValue))
End Function

...
q= --RegExpExtract(CStr(Arr_data(i, 15)), "нужный паттерн")
...

r = Application.Match(IIf(Split(RegExpExtract(.RefersToLocal, "[^={}]+"), ";")(0) = ID_ten, 1, Mid(RegExpExtract(RegExpExtract(.RefersToLocal, "[^={}]+"), ":" & ID_ten & "[^:]+"), 2)), Split(RegExpExtract(.RefersToLocal, "[^={}]+"), ":"), 0)

    Dim v_RegExp As Object, s As String
        Set v_RegExp = CreateObject("VBScript.RegExp")
            s = "2;2;222;202:5;155545;25;6:3;13;13;89"
            v_RegExp.Pattern = ":"
            v_RegExp.Global = True
            f = v_RegExp.Execute(s).Item(0).FirstIndex '11
            
            ff = InStr(s, ":5;") - 1 '11