h8nor

Option VBASupport 1
Option Compatible

А вот с макросами нужна помощь. Не затруднит прислать сам код (полный)?

' Автозамена используется при вводе данных (значение не может быть пустым)
With AutoCorrect.Entries
  .Add Name:="км.", Value:=" "
  .Add Name:="ул.", Value:=" "
End With
'123456789012345678901234567890123456h8nor@ya567890123456789012345678toster56789
' Есть стандартные функции автозамены. Вот некоторые из них:
With Options
  .AutoFormatAsYouTypeReplaceQuotes = False ' Автозамена ковычек
  .AutoFormatAsYouTypeReplaceFractions = False ' Автозамена дробей
End With

1. Включить в настройках вкладку "Разработчик", Режим конструктора, добавить Элементы управления (на картинке в красной рамке). Рекомендую через свойства полей указать ТЕГИ (например, dateProd, dateExp), и следить, чтобы не было разных полей с одинаковым тегом. Отключить Режим конструктора.
   
2. Открыть редактор VBA (первая кнопка во вкладке "Разработчик").
   
3. Создать модуль в документе. Написать функцию расчёта значения (для примера нужно прибавить 7 дней):
   

Sub ShelfLife()
  '3456789012345678901234567890123456h8nor@ya567890123456789012345678toster56789
  Dim objCC As ContentControl, counter As Variant
  Dim dateProdIndex As Byte, dateExpIndex As Byte
  
  With ActiveDocument
    For Each objCC In .ContentControls
      counter = counter + 1
      Select Case objCC.Tag
        Case "dateProd": dateProdIndex = counter
        Case "dateExp": dateExpIndex = counter
      End Select
    Next objCC: Set objCC = .ContentControls(dateProdIndex)
    
    If .ContentControls(dateExpIndex).LockContents _
      Xor objCC.PlaceholderText = objCC.Range.Text Then counter = 0
    
    If dateProdIndex > 0 And dateExpIndex > 0 And counter > 0 Then
      counter = CDbl(CDate(objCC.Range.Text)) + 7
      .ContentControls(dateExpIndex).Range.Text = CDate(counter)
    Else
      MsgBox "Поле с тегом dateProd или dateExp не заполнено. " & vbCrLf _
        & "Или содержимое поля dateExp нельзя редактировать. ", vbExclamation
    End If
  End With
End Sub

Sub SaveAsCSVinQuotes()
  Dim r As Range, c As Range, s As String
  '3456789012345678901234567890123456h8nor@ya567890123456789012345678toster56789
  s = Application.GetSaveAsFilename(FileFilter:="CSV файлы (*.csv), *.csv", _
    Title:="Сохранение CSV в кавычках (укажите разделитель в 1 строке SEP=" _
    & Application.International(xlListSeparator) & ")")
  If s = "False" Then Exit Sub
  Open s For Output As #1
  For Each r In ActiveSheet.UsedRange.Rows
    s = ""
    For Each c In r.Cells
      If c.Value2 Like "* *" Then s = s & ";" & """" & c & """" _
      Else s = s & ";" & c
    Next c: Print #1, Mid(s, 2)
  Next r: Close #1
End Sub

1. Можно промаркировать жёлтый текст и сделать замену прямо в Word (в примере 1 замена во всём тексте), или использовать закладки (Вставка (меню) -> Ссылки (группа) -> Закладки), или использовать инструмент Слияние и брать данные из файла Excel (без VBA). При слиянии связи могут глючить + конечный документ необходимо Объединить (как текущую запись), чтобы при работе с документом поля не обновлялись (Слияние использовать не советую). К тому же поля не поддерживают неразрывные символы Word'а Chr(160) и Chr(30).
   
   Примечание к документам слияния

   
   В таблице Excel есть поле Дата_1 (тип Дата) и поле Дата_2 (тип Дата). Если значение Дата_1 равно 43003 и значение Дата_2 равно 44764, то в формула ниже посчитается с ошибкой (будет значение ИСТИНА):
   

   { IF { MERGEFIELD Дата_1 \@"DD.MM.YYYY' г.'"  \* MERGEFORMAT } = { MERGEFIELD Дата_2 \@"DD.MM.YYYY' г.'"  \* MERGEFORMAT } "ИСТИНА" "ЛОЖЬ" }

   
   

   Option Explicit
   '123456789012345678901234567890123456h8nor@ya567890123456789012345678toster56789
   
   Sub Replacement_tags()
     Dim Content_Find As Find ' Объект Find
     
     Set Content_Find = ActiveDocument.Content.Find
     With Content_Find ' Найти маркер
       .ClearFormatting: .Replacement.ClearFormatting ' Очистить формат
       .MatchWildcards = False ' ВАЖНО! Отключить Подстановочные знаки
       
       .Text = "[Шапка]": .Replacement.Text = "Начальнику управления..."
       .Execute Forward:=True, Replace:=wdReplaceAll ' Заменить все маркеры [Шапка]
       
       ' Хитрость: перемещение курсора в конец заменённого текста
       .Execute FindText:=.Replacement.Text, _
         Forward:=True, Wrap:=wdFindStop, Replace:=wdReplaceNone
       .Parent.Select ' Выделяем текст для управления курсором
       'Selection.Collapse Direction:=wdCollapseEnd ' Курсор в конец найденного
     End With
   End Sub

2. Можно сразу заменить на дублированный текст:

   .Replacement.Text = "Начальнику управления..." & String(3, Chr(13)) & "Начальнику управления..."

   или вводить количество дублей в переменную Text перед заменой:

   ' Chr(13) - код символа возврата каретки. В других языках более привычная запись "\r"
   
     CapText = "Начальнику управления..."
     CapСount = InputBox("Введите количество 'Шапок'", , 1)
     If Not CInt(Val(CapСount)) = CapСount Then _
       MsgBox "Введите целое число", vbCritical: Exit Sub _
     Else Text = CapText
     
     While CapСount > 1
       Text = Text & String(3, Chr(13)) & CapText
       CapСount = CapСount - 1
     Wend

3. Таблицу можно также подтягивать через Слияние (точнее там создаётся объект OLE, которой глючит больше чем обычные поля - в основном это удержание файла Excel, откуда берутся данные). Удобнее программно создавать таблицу:

   ' Используем хитрость из п.1, если планируем создать таблицу в месте маркера
     
     Set tblNew = ActiveDocument.Tables.Add(Selection.Range, 3, 2)
     With tblNew
       .Columns(1).PreferredWidth = CentimetersToPoints(4) ' Колонка 1, Ширина 4 см
       .Borders(wdBorderTop).LineStyle = wdLineStyleNone ' Границы таблицы, например
       .Borders(wdBorderHorizontal).LineStyle = wdLineStyleSingle
       .Borders(wdBorderVertical).LineStyle = wdLineStyleDot
       For i = 1 To 2
         .Cell(1, i).Range.Text = "Строка 1; #" & i
       Next i
       .Cell(1, 1).Range.InsertAfter Chr(13) & "Строка 2" ' Добавить текст
       .Cell(tblNew.Rows.count, tblNew.Columns.count).Range.InsertAfter "Последняя ячейка"
     End With

4. Чтобы основной текст нельзя было отредактировать, проще всего создать шаблон Word с поддержкой макросов, основную процедуру (автозапуск) разместить в модуле ThisDocument:

   Private Sub Document_Open()
     Replacement_tags ' Процедура из п.1
   End Sub

   Данные для заполнения шаблона можно поместить в отдельный файл.
   

1. Открыть MS Word, в тексте написать маркер [Шапка]
2. Открыть VBA в приложении (Alt+F11)
3. Выбирать в меню Insert -> Module
4. Вставить процедуру (из п.1)
5. Нажать F5 (запустится процедура, в которой установлен курсор)

1. Понимание основ программирования (переменные/операторы/логические операции/циклы)
   
2. Понимание объектной структуры
   
3. Понимание поставленной задачи

Option Explicit
Option Base 1
'123456789012345678901234567890123456h8nor@ya567890123456789012345678toster56789

Sub Merge_by_Rows() ' Без форматирования границ
  Dim i As Integer, j As Integer, cnt As Integer
  Dim arr() As Variant, s As String
  
  With ActiveSheet.UsedRange ' Кол-во столбцов определяется по 1-й строке
    arr = Range(Cells(1, 1), Cells(.Rows.Count + 1, Range("A1").End(xlToRight).Column))
  End With
  
  cnt = 1: s = get_Row(arr, cnt)
  For i = LBound(arr, 1) + 1 To UBound(arr, 1)
    If get_Row(arr, i) <> s Then
      For j = LBound(arr, 2) To UBound(arr, 2)
        With ActiveSheet.Range(Cells(cnt, j), Cells(i - 1, j)).Offset(, UBound(arr, 2))
          .Merge
          .HorizontalAlignment = xlCenter
          .VerticalAlignment = xlCenter
          .Value = arr(cnt, j)
        End With
      Next j
      cnt = i: s = get_Row(arr, cnt)
    End If
  Next i
End Sub

Function get_Row(ByVal arr As Variant, ByVal num_Row As Integer) As String
  Dim j As Integer
  
  For j = LBound(arr, 2) To UBound(arr, 2)
    get_Row = WorksheetFunction.Trim(get_Row & " " & arr(num_Row, j))
  Next j
End Function

Option Explicit ' Обязательное объявление переменных
Option Base 1 ' Нижняя граница массива (по умолчанию)
'123456789012345678901234567890123456h8nor@ya567890123456789012345678toster56789

Sub Border_Limit()
  Dim Limit As Integer, Count As Integer, SaveDir As String, SetTitle As Boolean
  
  Count = 1: Limit = 1000 ' Счётчик файлов; Количество строк
  SetTitle = False ' Если есть заголовок, заменить False на True
  
  SaveDir = ThisWorkbook.Path ' Или вписать полный путь для сохранения "C:\"
  ' Предполагается, что в колонке A нет пустых ячеек
  While Not IsEmpty(Cells(IIf(SetTitle, 2, 1), 1))
    Rows("1:" & Limit).Copy
    Workbooks.Add xlWBATWorksheet ' Создать новую книгу: шаблон с 1 листом
    ActiveSheet.Paste: Cells(1, 1).Select
    ActiveWorkbook.SaveAs Filename:=SaveDir & "\Массив_" & Count & ".xlsx", _
      FileFormat:=xlOpenXMLWorkbook
    ActiveWindow.Close
    Rows(IIf(SetTitle, 2, 1) & ":" & Limit).Delete Shift:=xlUp
    Count = Count + 1
  Wend: MsgBox "Файл разбит на " & Count - 1 & " файл(ов). "
End Sub

' Не самый оптимальный, но наглядный способ. Ctrl+Break - экстренная остановка.
Option Explicit
'123456789012345678901234567890123456h8nor@ya567890123456789012345678toster56789

Sub Макрос1()
  Dim i As Long
  
  i = 3 ' Формулу будем копировать с 3-й строки
  With ThisWorkbook.ActiveSheet
    Do
      i = i + 1
      .Range("H" & i & ":K" & i) = .Range("H" & i - 1 & ":K" & i - 1).FormulaR1C1
    Loop Until i = .UsedRange.Rows.Count ' Цикл ДО последней строки с данными
  End With
End Sub