Форум по VBA и MS Office

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

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