Макрос для копирования определенного количества символов

Dim D As Word.Document

    Set D = ActiveDocument
    D.BuiltInDocumentProperties(wdPropertyAuthor).Value = Selection.Text
    ' или так
    D.CustomDocumentProperties.Add _
        Name:="Свойство1", _
        LinkToContent:=False, _
        Type:=msoPropertyTypeString, _
        Value:=Selection.Text
    ' или так
    D.CustomDocumentProperties("Свойство1").Value = Selection.Text

Const c_Length& = 32768 ' длина блока

Dim D As Word.Document
Dim R As Word.Range
Dim N&

    N = 0 ' счетчик блоков
    Set D = ActiveDocument
    ' начало текста
    Set R = D.Range(0, 0)
    ' захват текста
    Do While R.MoveEnd(Unit:=wdCharacter, Count:=c_Length) > 0
        ' запись свойства
        N = N + 1
        D.CustomDocumentProperties.Add _
            Name:="Блок " & CStr(N), _
            LinkToContent:=False, _
            Type:=msoPropertyTypeString, _
            Value:=R.Text
        ' конец документа
        If R.End >= R.StoryLength Then Exit Do
        ' конец текста
        R.Collapse Direction:=Word.wdCollapseEnd
    Loop