Word VBA Макросы: Пакетное редактирование шаблонов: замена части данных в шаблоне .dotm из документов .doc и сохранение в .dotm с именем файлов .doc

[Евгений Второй]

Имеется шаблон документа .dotm, нужно взять из других документов .doc содержимое двух полей, заменить ими аналогичные данные шаблона и сохранить результирующие файлы в шаблоны в формате .dotm с именами вышеописанных документов .doc.

Сценарий: есть шаблон "Образец.dotm" и документы *.doc. Имя файлов .doc - величина переменная. В шаблоне "Образец.dotm" 2 значения заменяются данными из аналогичных полей документов "*. doc" и полученные документы сохраняется в виде "*.dotm" (с именами .doc, из которых брались изменяемые данные).
Буду благодарен за помощь.

[Администратор]

А где документы находятся? В одной какой-то папке?

[Евгений Второй]

Вообще в вложенных папках одной основной папки "Шаблоны", хотя если это сложно - можно их вытащить все в одну папку, потом рассортировать в разные снова.

[Администратор]

А шаблоны в какую папку сохранять? Где находится основной шаблон? Или в другие папки?

[Евгений Второй]

Можно в папку с образцом. Или в папки с одноимёнными .doc

[Администратор]

Имена у документов все разные или могут быть одинаковые? Если могут быть одинаковые, то в одной папке не может быть два файла с одинаковым именем.

[Евгений Второй]

На 100% не скажу, но вроде все отличаются. Чем грозит, если повторяются? В подпапках точно не повторяются.

[Администратор]

Будет сохранён только один файл, т.к. макрос перезаписывает имеющийся файл.

[Евгений Второй]

Не страшно, я сначала проверю, скопировав все файлы в одну папку.

[Администратор]

В процедуре "макрос", в пунктах 1, 3, 4.3 укажите соответствующие пути, имена файлов.

Макрос

Sub макрос()

    Dim FNs As New Collection, shablon As Document, doc As Document
    Dim text As String
    Dim i As Long
   
   
    '1. Запись в коллекцию "FNs" полных имён всех папок и файлов, которые находятся в заданной папке.
    FoldersFilesSearch "C:\Users\User\Desktop\Новая папка", FNs
    ' Удаление первого элемента - это родительская папка.
    FNs.Remove 1
   
    '2. Оставление в коллекции только файлов с расширением "doc".
    For i = FNs.Count To 1 Step -1
        If Not LCase(FNs(i)) Like "*.doc" Then
            FNs.Remove i
        End If
    Next i
    ' Если в выбранной папке нет файлов с расширением "doc".
    If FNs.Count = 0 Then
        MsgBox "В выбранной папке нет doc-файлов.", vbExclamation
        Exit Sub
    End If
   
    ' Отключение монитора (может это ускорит макрос и чтобы не мерцало).
    Application.ScreenUpdating = False
   
    '3. Открываем шаблон и присваиваем ему имя "shablon",
        ' затем по этому имени будем обращаться к шаблону.
    Set shablon = Documents.Open(FileName:="C:\Users\User\Desktop\Новая папка\Образец.dotm")
   
    '4. Копирование данных из документов в шаблон и сохранение шаблона.
    ' Цикл по doc-файлам.
    For i = 1 To FNs.Count
   
        '1) Открытие документа и присвоение ему имени "doc".
        Set doc = Documents.Open(FileName:=FNs(i), ReadOnly:=True)
       
        '2) Копирование данных из документа в шаблон.
            ' Копирование сначала в переменную, чтобы удалить с конца два спецсимвола.
            ' В конце каждой ячейки есть два спецсимвола. Один видно в режиме непечатаемых
            ' символов, он в виде кружка, второй вообще никогда не видно.
        text = doc.Tables(2).Cell(1, 1).Range.text
        text = Left(text, Len(text) - 2)
        shablon.Tables(2).Cell(1, 1).Range.text = text
       
        text = doc.Tables(3).Cell(1, 1).Range.text
        text = Left(text, Len(text) - 2)
        shablon.Tables(3).Cell(1, 1).Range.text = text
   
        '3) Сохранение и закрытие шаблона.
        shablon.SaveAs2 _
            FileName:="C:\Users\User\Desktop\Новая папка\" & Left(doc.Name, InStrRev(doc.Name, ".") - 1) & ".dotm", _
            FileFormat:=wdFormatXMLTemplateMacroEnabled
       
        '4) Закрытие документа.
        doc.Close SaveChanges:=False
       
    Next i
   
    '5. Закрытие шаблона.
    shablon.Close SaveChanges:=False
       
    '6. Сообщение.
    Application.ScreenUpdating = True
    MsgBox "Готово.", vbInformation
   
End Sub

Private Sub FoldersFilesSearch(FN_folder As String, FNs As Collection)

    Dim FNs_Subfolders As New Collection
    Dim str_name As String, i As Long
   
   
    '1. Запись в коллекцию "FNs" полного имени текущей папки.
    FNs.Add Item:=FN_folder
   
    '2. Поиск в текущей папке папок и файлов.
    str_name = Dir(FN_folder & "\", vbDirectory)
    Do While str_name <> ""
        If (GetAttr(FN_folder & "\" & str_name) And vbDirectory) <> 0 Then
            If (str_name <> ".") And (str_name <> "..") Then
                ' Запись в aux-коллекцию полного имени папки,
                    ' которая находится внутри текущей папки.
                FNs_Subfolders.Add Item:=FN_folder & "\" & str_name
            End If
        Else
            ' Запись в коллекцию "FNs" полного имени файла, который находится внутри текущей папки.
            FNs.Add Item:=FN_folder & "\" & str_name
        End If
        str_name = Dir()
    Loop
   
    '3. Просмотр папок, которые находятся внутри текущей папки.
    If FNs_Subfolders.Count <> 0 Then
        For i = 1 To FNs_Subfolders.Count Step 1
            Call FoldersFilesSearch(FNs_Subfolders(i), FNs)
        Next i
    End If
   
End Sub

[свернуть]

[Евгений Второй]

Спасибо, всё работает.

[Евгений Второй]

А структуру подпапок добавить для сохранения сложно?

В основной папке есть вложенные папки с .doc "донорами", из которых берутся данные для замены. В идеале раскидывать бы получившиеся шаблоны по папкам с такими же названиями, как у папок, из которых файлы берутся. Пример: берётся файл .doc из папки "123", вложенной в общую папку "Шаблоны", где есть еще папки "456" и тд. После импорта его данных в шаблон, тот сохраняется с этим же именем в папку "123", вложенную в общую папку "результаты". Сейчас все получившиеся шаблоны складываются в корень  в корень папки "результаты". Папки могут создаваться автоматически? Если нет - можно скопировать туда готовые. Но это так, уже мелкая хотелка, основная задача решена отлично.

[Администратор]

Полные имена папок и файлов укажите в процедуре "макрос" в пунктах 1, 2, 7.
В пункте 7 можно использовать два варианта:
1) укажите только имя шаблона;
2) укажите полное имя шаблона, если путь шаблона другой, чем в переменной "FN_main", а переменную "FN_main" удалите.

Папка "Результаты" может быть в любом месте, а не обязательно в основной папке.

Макрос

Sub макрос()

    Dim FNs As New Collection, shablon As Document, doc As Document
    Dim text As String, FN_main As String, FN_new As String, FN_res As String
    Dim i As Long
   
   
    '1. Основная папка. В которой находится шаблон и папки с документами.
        ' Кроме того, документы могут находиться непосредственно в самой основной папке,
        ' а не во вложенной.
    FN_main = "C:\Users\User\Desktop\Основная папка"
   
    '2. Папка для новых шаблонов.
    FN_res = "C:\Users\User\Desktop\Результат"
   
    ' Отключение монитора (может это ускорит макрос и чтобы не мерцало).
    Application.ScreenUpdating = False
   
    '3 Проверка, что существует папка-результат.
    If Dir(FN_res, vbDirectory) = "" Then
        Application.ScreenUpdating = True
        MsgBox "Создайте папку-результат:" & vbCr & FN_res, vbExclamation
        Exit Sub
    End If
   
    '4. Запись в коллекцию "FNs" полных имён всех папок и файлов, которые находятся в заданной папке.
    FoldersFilesSearch FN_main, FNs
    ' Удаление первого элемента - это родительская папка.
    FNs.Remove 1
   
    '5. Оставление в коллекции только файлов с расширением "doc".
    For i = FNs.Count To 1 Step -1
        If Not LCase(FNs(i)) Like "*.doc" Then
            FNs.Remove i
        End If
    Next i
    ' Если в выбранной папке нет файлов с расширением "doc".
    If FNs.Count = 0 Then
        Application.ScreenUpdating = True
        MsgBox "В выбранной папке нет doc-файлов.", vbExclamation
        Exit Sub
    End If
   
    '6. Создание папок для новых шаблонов.
    CreateFolders FN_main, FN_res, FNs
   
    '7. Открываем шаблон и присваиваем ему имя "shablon",
        ' затем по этому имени будем обращаться к шаблону.
    Set shablon = Documents.Open(FileName:=FN_main & "\Образец.dotm")
   
    '8. Копирование данных из документов в шаблон и сохранение шаблона.
    ' Цикл по doc-файлам.
    For i = 1 To FNs.Count
   
        '1) Открытие документа и присвоение ему имени "doc".
        Set doc = Documents.Open(FileName:=FNs(i), ReadOnly:=True)
       
        '2) Копирование данных из документа в шаблон.
            ' Копирование сначала в переменную, чтобы удалить с конца два спецсимвола.
            ' В конце каждой ячейки есть два спецсимвола. Один видно в режиме непечатаемых
            ' символов, он в виде кружка, второй вообще никогда не видно.
        text = doc.Tables(2).Cell(1, 1).Range.text
        text = Left(text, Len(text) - 2)
        shablon.Tables(2).Cell(1, 1).Range.text = text
       
        text = doc.Tables(3).Cell(1, 1).Range.text
        text = Left(text, Len(text) - 2)
        shablon.Tables(3).Cell(1, 1).Range.text = text
   
        '3) Формирование полного имени для нового файла.
        ' Оставляем фрагмент полного имени внутри основной папки.
        FN_new = Replace(FNs(i), FN_main, "", , 1)
        ' Изменение расширения файла.
        FN_new = Left(FN_new, InStrRev(FN_new, ".") - 1) & ".dotm"
        ' Добавляем полное имя папки для результатов.
        FN_new = FN_res & FN_new
       
        '4) Сохранение и закрытие шаблона.
        shablon.SaveAs2 FileName:=FN_new, FileFormat:=wdFormatXMLTemplateMacroEnabled
       
        '5) Закрытие документа.
        doc.Close SaveChanges:=False
       
    Next i
   
    '9. Закрытие шаблона.
    shablon.Close SaveChanges:=False
       
    '10. Сообщение.
    Application.ScreenUpdating = True
    MsgBox "Готово.", vbInformation
   
End Sub

Private Sub FoldersFilesSearch(FN_folder As String, FNs As Collection)

    ' Запись в коллекцию "FNs" полных имён всех папок и файлов, которые находятся в заданной папке.
   
    Dim FNs_Subfolders As New Collection
    Dim str_name As String, i As Long
   
   
    '1. Запись в коллекцию "FNs" полного имени текущей папки.
    FNs.Add Item:=FN_folder
   
    '2. Поиск в текущей папке папок и файлов.
    str_name = Dir(FN_folder & "\", vbDirectory)
    Do While str_name <> ""
        If (GetAttr(FN_folder & "\" & str_name) And vbDirectory) <> 0 Then
            If (str_name <> ".") And (str_name <> "..") Then
                ' Запись в aux-коллекцию полного имени папки,
                    ' которая находится внутри текущей папки.
                FNs_Subfolders.Add Item:=FN_folder & "\" & str_name
            End If
        Else
            ' Запись в коллекцию "FNs" полного имени файла, который находится внутри текущей папки.
            FNs.Add Item:=FN_folder & "\" & str_name
        End If
        str_name = Dir()
    Loop
   
    '3. Просмотр папок, которые находятся внутри текущей папки.
    If FNs_Subfolders.Count <> 0 Then
        For i = 1 To FNs_Subfolders.Count Step 1
            Call FoldersFilesSearch(FNs_Subfolders(i), FNs)
        Next i
    End If
   
End Sub

Private Sub CreateFolders(FN_main As String, FN_res As String, FNs As Collection)

    ' Создание папок для новых шаблонов.
   
    Dim NewFolder As String, NewFragment As String
    Dim spl, i As Long, ii As Long
   
   
    ' Цикл по полным именам файлов-источников.
    For i = 1 To FNs.Count
   
        '1) Удаление из полного имени файла полного имени основной папки.
        NewFragment = Replace(FNs(i), FN_main, "", , 1)
       
        '2) Удаление из оставшегося полного имени файла имени файла.
        NewFragment = Left(NewFragment, InStrRev(NewFragment, "\") - 1)
       
        '3) Если стало пусто, значит файл находится непосредственно в основной папке, а не во
            ' вложенной папке и не нужно создавать папку, т.к. основная папка и так уже существует.
        If NewFragment = "" Then
            GoTo metka_NextFN
        End If
       
        '4) Удаление из оставшегося полного имени левого слеша.
        NewFragment = Mid(NewFragment, 2)
       
        '5) Создание папки.
        spl = Split(NewFragment, "\")
        NewFolder = FN_res
        For ii = 0 To UBound(spl)
            NewFolder = NewFolder & "\" & spl(ii)
            If Dir(NewFolder, vbDirectory) = "" Then
                MkDir NewFolder
            End If
        Next ii

metka_NextFN:
    Next i
   
End Sub

[свернуть]

[Евгений Второй]

Всё работает отлично, спасибо.