1

Тема: Нужно автоматически создать отдельный файл doc на каждого из списка

Приветствую! Имеется один большой список doc файл - ФИО  и данные о занимаемой должности и тд, нужно на каждого автоматически создать отдельный файл лучше в отдельном каталоге с данными из списка

2

Re: Нужно автоматически создать отдельный файл doc на каждого из списка

Выложите образец файла

3

Re: Нужно автоматически создать отдельный файл doc на каждого из списка

Да, спасибо за отклик, вот фрагмент

Post's attachments

фрагмент списка.doc 39.5 Кб, 17 скачиваний с 2012-07-20 

You don't have the permssions to download the attachments of this post.

4

Re: Нужно автоматически создать отдельный файл doc на каждого из списка

В принципе ни чего сложного, но код напишу завтра с утра, сегодня уже поздно

5

Re: Нужно автоматически создать отдельный файл doc на каждого из списка

спасибо, буду ждать

6

Re: Нужно автоматически создать отдельный файл doc на каждого из списка

Извиняюсь как там с кодом??

7

Re: Нужно автоматически создать отдельный файл doc на каждого из списка

Выкладываю

8

Re: Нужно автоматически создать отдельный файл doc на каждого из списка

В общем песня такая.
I. Импортируете вложенный модуль в проект Normal
II. Макрос называется SaveFiles
III. Описание макроса
1. Открываете файл оригинал
2. Выделяете определенное количество фамилий (весь файл выделять не рекомендую)
3. Вводите имя основной папки куда треба сохранить файлы
4. Во время создания файлов в файле-оригинале готовые фамилии будут выделяться красным.
5. В каталога создается папка с 1-й буквой фамилии, а в ней отдельная папка на каждую фамилию
6. Дождитесь завершения макроса
Для продолжения работы выделите другие фамилии не отмеченные красным.
P.S. Прежде чем работать с основным файлом потренируйтесь на фрагментах.
Пишите если возникнут вопросы

Post's attachments

SaveFileInText.rar 1.1 Кб, 5 скачиваний с 2012-07-20 

You don't have the permssions to download the attachments of this post.

9

Re: Нужно автоматически создать отдельный файл doc на каждого из списка

Вот доработанный модуль

Post's attachments

SaveFileInText.rar 1.32 Кб, 6 скачиваний с 2012-07-20 

You don't have the permssions to download the attachments of this post.

10

Re: Нужно автоматически создать отдельный файл doc на каждого из списка

Извините, с чего начать у меня Word 2003? Где найти проект?

11

Re: Нужно автоматически создать отдельный файл doc на каждого из списка

Извините, вроде нашел инструкцию

12

Re: Нужно автоматически создать отдельный файл doc на каждого из списка

Спасибо, вроде разобрался, а можно ли автоматизировать и не подтверждать содание каждого файла?

13

Re: Нужно автоматически создать отдельный файл doc на каждого из списка

В посте №9 выложен модернизированный модуль. На Вашем фрагменте у меня работает только в путь. Удалите старый модуль и импортируйте новый.

14

Re: Нужно автоматически создать отдельный файл doc на каждого из списка

Файлы почему-то создает в папке Мои документы и каждый раз просит подтверждение создания каждого файла.

15

Re: Нужно автоматически создать отдельный файл doc на каждого из списка

А разобрался, файлы будут создаваться в папке которую я укажу.
Ну вот все равно просит подтверждения, можно ли что сделать?

16

Re: Нужно автоматически создать отдельный файл doc на каждого из списка

Сделайте так:
1. Откройте VBAредактор
2. Щелкните правым кликом на проекте Normal
3. В открывшемся меню выберете Insert-->Module
4. Запомните номер Module
5. Скопируйте в него код

Public Fold1 As String
Public FoldsPref As String
Public FoldName As String
Public FileName As String

Private Function SelFiles() As Collection
Dim col As Collection, pr As Collection, col1 As Collection
Dim Prg As Paragraph, Rng As Range, WD As Range
Dim NameFold As String, i As Byte, Name As String
    Selection.Find.ClearFormatting
    Selection.Find.Font.Bold = False
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "([!^0013])([^0013])([!^0013])"
        .Replacement.Text = "\1 \3"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    Set SelFiles = New Collection
    For Each Prg In Selection.Paragraphs
        Set pr = New Collection
        Set Rng = Prg.Range
            If Rng.Words(1).Font.Bold = True Then
            i = i + 1
                Set col = New Collection
                    col.Add Rng.Words(1).Characters.First.Text, "Pref"
                        NameFold = ""
                            For Each WD In Rng.Words
                                If WD.Font.Bold = True Or WD.Text = Chr(12) Then
                                    NameFold = NameFold & WD
                                Else
                                    Exit For
                                End If
                            Next WD
                            NameFold = Trim(NameFold)
                                            For j = Len(NameFold) To 1
                                                If Mid(NameFold, j, 1) = "," Then
                                                    NameFold = Mid(NameFold, j - 1, 1)
                                                    NameFold = Trim(NameFold)
                                                End If
                                            Next j
                    col.Add NameFold, "NameFold"
                    col.Add Prg.Range, "Range"
                    col.Add Trim(Rng.Words(1)) & ".doc", "Name"
                    SelFiles.Add col
            End If
    Next Prg
End Function

Public Sub SaveFiles()
Dim mFiles As Collection, Doc1 As Document
Dim appWD As Application, Doc2 As Document, i As Long
Dim col As Collection, Rng As Range
    Set mFiles = SelFiles
    Set Doc1 = ActiveDocument
    Set appWD = New Application
    appWD.Visible = False
        On Error Resume Next
        Fold1 = InputBox("Введите каталог сохранения файлов!")
        If Fold1 = "" Then Exit Sub
        If Mid(Fold1, Len(Fold1), 1) = "\" Then
            Fold1 = Trim(Mid(Fold1, 1, Len(Fold1) - 1))
        End If
             On Error Resume Next
                MkDir Fold1
                For i = 1 To mFiles.Count
                    Set col = mFiles(i)
                        On Error Resume Next
                        MkDir Fold1 & "\" & col("Pref")
                        FoldsPref = Fold1 & "\" & col("Pref")
                        MkDir FoldsPref & "\" & col("NameFold")
                        FoldName = FoldsPref & "\" & col("NameFold")
                        FileName = FoldName & "\" & col("Name")
                        Set Rng = col("Range")
                            With appWD
                                Set Doc2 = .Documents.Add
                                Rng.Copy
                                Rng.HighlightColorIndex = wdRed
                                Doc2.Range.PasteAndFormat (wdFormatOriginalFormatting)
                                Doc2.SaveAs2 FileName:=FileName, FileFormat:= _
                                    wdFormatDocument, LockComments:=False, Password:="", AddToRecentFiles:= _
                                    True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:= _
                                    False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
                                    SaveAsAOCELetter:=False, CompatibilityMode:=0
                                Doc2.Close
                            End With
                Next i
appWD.Quit
    MsgBox "Создано " & mFiles.Count & " файлов", vbInformation
End Sub

Если 1-я строка в модуле Option Explicit Удалите ее
5. Нажмите Ctrl+S
6. Закройте VBA
7. Откройте тестируемый файл
8. Выделите любое количество фамилий
9. Откройте меню макросов и выберете нужный макрос например Normal.Module6.SaveFiles
10. Запустите макрос
11. В открывшемся окне наберите путь каталога например C:\myTest
Если этого пути не существует, макрос автоматом создаст каталог
12. Нажмите OK и дождитесь окончания макроса
13. Откройте каталог C:\myTest и проверьте сохраненные файлы

17

Re: Нужно автоматически создать отдельный файл doc на каждого из списка

Извините, что-то не так, файлы все создаются в первой папке, а в остальных пусто и все равно просит подтверждение создания файлов

18

Re: Нужно автоматически создать отдельный файл doc на каждого из списка

структуру папок создает правильно, но просит указать папку для файла, вот бы сам все делал

19

Re: Нужно автоматически создать отдельный файл doc на каждого из списка

Попробуйте заменить строку

Doc2.SaveAs2 FileName:=FileName, FileFormat:= _
                                    wdFormatDocument, LockComments:=False, Password:="", AddToRecentFiles:= _
                                    True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:= _
                                    False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
                                    SaveAsAOCELetter:=False, CompatibilityMode:=0

на

Doc2.SaveAs FileName:=FileName, FileFormat:= _
                                    wdFormatDocument, LockComments:=False, Password:="", AddToRecentFiles:= _
                                    True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:= _
                                    False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
                                    SaveAsAOCELetter:=False, CompatibilityMode:=0

20

Re: Нужно автоматически создать отдельный файл doc на каждого из списка

Выдает ошибку

Compile error         Named argument not found

и подчеркнуто     CompatibilityMode:=

21

Re: Нужно автоматически создать отдельный файл doc на каждого из списка

Тогда оставьте только

Doc2.SaveAs FileName:=FileName, FileFormat:= wdFormatDocument   

Если не получится, тогда:
1. Создайте новый документ
2. Включите Запись макроса
3. Назовите его Save
4. Нажмите Сохранить как... и Сохраните документ
5. Остановите макрос
6. Откройте VBA-->Normal-->NewMacros
7. Найдите код макроса
8. Замените ActiveDocument на Doc2
9. FileName:= должно быть FileName:=FileName
10. Вставьте данный код вместо Doc2.SaveAs

22

Re: Нужно автоматически создать отдельный файл doc на каждого из списка

Извините, оставил только одну строку, все работает автоматом, но имена самих файлов в папках всегда одинаковый - только фамилия, а нужно чтобы было как в списке, это реально?

23

Re: Нужно автоматически создать отдельный файл doc на каждого из списка

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

24

Re: Нужно автоматически создать отдельный файл doc на каждого из списка

Сказали можно без папок но название файлов должно быть как в списке, то есть первая папка с букой и достаточно - в ней только файлы без доп папок с именем, если есть время попробуйте пожалуйста

25

Re: Нужно автоматически создать отдельный файл doc на каждого из списка

Извините если у Вас есть минутка попробуйте пожалуйста,
нужна папка с первой буквой и в ней все файлы с названием из списка на эту букву, буду очень признателен

26

Re: Нужно автоматически создать отдельный файл doc на каждого из списка

Замените весь старый код на новый

Public Fold1 As String
Public FoldsPref As String
Public FoldName As String
Public FileName As String

Private Function SelFiles() As Collection
Dim col As Collection, pr As Collection, col1 As Collection
Dim Prg As Paragraph, Rng As Range, WD As Range
Dim NameFold As String, i As Byte, Name As String
    Selection.Find.ClearFormatting
    Selection.Find.Font.Bold = False
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "([!^0013])([^0013])([!^0013])"
        .Replacement.Text = "\1 \3"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    Set SelFiles = New Collection
    For Each Prg In Selection.Paragraphs
        Set pr = New Collection
        Set Rng = Prg.Range
            If Rng.Words(1).Font.Bold = True Then
            i = i + 1
                Set col = New Collection
                    col.Add Rng.Words(1).Characters.First.Text, "Pref"
                        NameFold = ""
                            For Each WD In Rng.Words
                                If WD.Font.Bold = True Or WD.Text = Chr(12) Then
                                    NameFold = NameFold & WD
                                Else
                                    Exit For
                                End If
                            Next WD
                            NameFold = Trim(NameFold)
                                            For j = Len(NameFold) To 1
                                                If Mid(NameFold, j, 1) = "," Then
                                                    NameFold = Mid(NameFold, j - 1, 1)
                                                    NameFold = Trim(NameFold)
                                                End If
                                            Next j
                    col.Add NameFold, "NameFold"
                    col.Add Prg.Range, "Range"
                    col.Add Trim(Rng.Words(1)) & ".doc", "Name"
                    SelFiles.Add col
            End If
    Next Prg
End Function

Public Sub SaveFiles()
Dim mFiles As Collection, Doc1 As Document
Dim appWD As Application, Doc2 As Document, i As Long
Dim col As Collection, Rng As Range
    Set mFiles = SelFiles
    Set Doc1 = ActiveDocument
    Set appWD = New Application
    appWD.Visible = False
    Set Doc2 = appWD.Documents.Add
        On Error Resume Next
        Fold1 = InputBox("Введите каталог сохранения файлов!")
        If Fold1 = "" Then Exit Sub
        If Mid(Fold1, Len(Fold1), 1) = "\" Then
            Fold1 = Trim(Mid(Fold1, 1, Len(Fold1) - 1))
        End If
             On Error Resume Next
                MkDir Fold1
                For i = 1 To mFiles.Count
                    Set col = mFiles(i)
                        On Error Resume Next
                        MkDir Fold1 & "\" & col("Pref")
                        FoldsPref = Fold1 & "\" & col("Pref")
                        s = col("NameFold")
                        FileName = ""
                            For j = 1 To Len(s)
                                If Mid(s, j, 1) >= "A" And Mid(s, j, 1) <= "z" Then
                                    FileName = FileName & Mid(s, j, 1)
                                ElseIf Mid(s, j, 1) >= "А" And Mid(s, j, 1) <= "я" Then
                                    FileName = FileName & Mid(s, j, 1)
                                ElseIf Mid(s, j, 1) = Chr(32) Then
                                    FileName = FileName & Mid(s, j, 1)
                                End If
                            Next j
                        FileName = FoldsPref & "\" & FileName & ".doc"
                        Debug.Print FileName
                        Set Rng = col("Range")
                                Rng.Copy
                                Rng.HighlightColorIndex = wdRed
                                Doc2.Range.PasteAndFormat (wdFormatOriginalFormatting)
                                Doc2.SaveAs FileName:=FileName, FileFormat:= _
                                    wdFormatDocument
                Next i
Doc2.Close 0
appWD.Quit
    MsgBox "Создано " & mFiles.Count & " файлов", vbInformation
End Sub

27

Re: Нужно автоматически создать отдельный файл doc на каждого из списка

Спасибо скрипт работает, конечно если не большой объем фамилий, выделяю по несколько страниц, иначе ошибка и ссылка на формулу i=i+1
Но по чуть-чуть получается.

Вот еще понадобилось в конце каждого файла добавить строчку -


______________________________________________
Для получения полной архивной справки по этому че-ловеку, а также фотоматериалов с ним, пишите архи-вариусу: maximmurmansk@mail.ru

Подскажите самый простой вариант или может в скрипт добавить, спасибо за помощь

28

Re: Нужно автоматически создать отдельный файл doc на каждого из списка

Вот замена для процедуры Public Sub SaveFiles

Public Sub SaveFiles()
Dim mFiles As Collection, Doc1 As Document
Dim appWD As Application, Doc2 As Document, i As Long
Dim col As Collection, Rng As Range
    Set mFiles = SelFiles
    Set Doc1 = ActiveDocument
    Set appWD = New Application
    appWD.Visible = False
    Set Doc2 = appWD.Documents.Add
        On Error Resume Next
        Fold1 = InputBox("Введите каталог сохранения файлов!")
        If Fold1 = "" Then Exit Sub
        If Mid(Fold1, Len(Fold1), 1) = "\" Then
            Fold1 = Trim(Mid(Fold1, 1, Len(Fold1) - 1))
        End If
             On Error Resume Next
                MkDir Fold1
                For i = 1 To mFiles.Count
                    Set col = mFiles(i)
                        On Error Resume Next
                        MkDir Fold1 & "\" & col("Pref")
                        FoldsPref = Fold1 & "\" & col("Pref")
                        s = col("NameFold")
                        FileName = ""
                            For j = 1 To Len(s)
                                If Mid(s, j, 1) >= "A" And Mid(s, j, 1) <= "z" Then
                                    FileName = FileName & Mid(s, j, 1)
                                ElseIf Mid(s, j, 1) >= "А" And Mid(s, j, 1) <= "я" Then
                                    FileName = FileName & Mid(s, j, 1)
                                ElseIf Mid(s, j, 1) = Chr(32) Then
                                    FileName = FileName & Mid(s, j, 1)
                                End If
                            Next j
                        FileName = FoldsPref & "\" & FileName & ".doc"
                        Set Rng = col("Range")
                                Rng.Copy
                                Rng.HighlightColorIndex = wdRed
                                Doc2.Range.PasteAndFormat (wdFormatOriginalFormatting)
                                Doc2.Range.Paragraphs(Doc2.Range.Paragraphs.Count).Range.Delete
                                Doc2.Range.Footnotes.Add Doc2.Range(Doc2.Range.End - 1, Doc2.Range.End - 1), , _
                                "Для получения полной архивной справки по этому человеку, а также фотоматериалов с ним, пишите архивариусу: maximmurmansk@mail.ru"
                                Doc2.SaveAs FileName:=FileName, FileFormat:= _
                                    wdFormatDocument
                Next i
Doc2.Close 0
appWD.Quit
    MsgBox "Создано " & mFiles.Count & " файлов", vbInformation
End Sub

В конце странице добавляется сноска с Вашим текстом
Надо заново все фамилии делать, а для уже сделанных придется скрипт писать, а это работа

29

Re: Нужно автоматически создать отдельный файл doc на каждого из списка

Спасибо все получилось а как можно шрифт немного увеличить этой добавочной ссылки?

30

Re: Нужно автоматически создать отдельный файл doc на каждого из списка

После строки

Doc2.Range.Footnotes.Add Doc2.Range(Doc2.Range.End - 1, Doc2.Range.End - 1), , _
                                "Для получения полной архивной справки по этому человеку, а также фотоматериалов с ним, пишите архивариусу: maximmurmansk@mail.ru"

добавьте строку
Doc2.Range.Footnotes(1).Range.Font.Size = [размер шрифта]

31

Re: Нужно автоматически создать отдельный файл doc на каждого из списка

Вы просто база знаний!
Еще маленькая прихоть, можно ли сделать чтобы мой адрес был как ссылка чтобы сразу написать письмо, вроде это как гиперссылка, если не ошибаюсь

32

Re: Нужно автоматически создать отдельный файл doc на каждого из списка

Извините, если это сложно,может просто что-то посоветуете

33

Re: Нужно автоматически создать отдельный файл doc на каждого из списка

в ворде есть поле, написано введите вопрос, напишите гиперссылка и отталкивайтесь оттуда

34

Re: Нужно автоматически создать отдельный файл doc на каждого из списка

В тоже место куда вставляли строку
Doc2.Range.Footnotes(1).Range.Font.Size = [размер шрифта]
Втавтье код

With Doc2.Footnotes(1).Range.Paragraphs(1).Range.Hyperlinks
      .Add Doc2.Footnotes(1).Range.Paragraphs(1).Range, _
     "mailto:maximmurmansk@mail.ru"
End With

После выполнения этого кода в любом месте сноски при нажатой клавише Ctrl, будет открываться окно электронной почты

35

Re: Нужно автоматически создать отдельный файл doc на каждого из списка

Извините, можно чтобы подчеркнутым был только мой адрес, а то сложности возникают

36

Re: Нужно автоматически создать отдельный файл doc на каждого из списка

With Doc2.Footnotes(1).Range.Paragraphs(1).Range.Hyperlinks
      .Add Doc2.Footnotes(1).Range.Words(Doc2.Footnotes(1).Range.Words.Count - 1), _
     "mailto:maximmurmansk@mail.ru"
End With

37

Re: Нужно автоматически создать отдельный файл doc на каждого из списка

Извините вот код

With Doc2.Footnotes(1).Range.Paragraphs(1).Range.Hyperlinks
      .Add Doc2.Range(Doc2.Footnotes(1).Range.Words(Doc2.Footnotes(1).Range.Words.Count - 5).Start, Doc2.Footnotes(1).Range.Words(Doc2.Footnotes(1).Range.Words.Count - 1).End) _
     "mailto:maximmurmansk@mail.ru"
End With

38

Re: Нужно автоматически создать отдельный файл doc на каждого из списка

Syntax error и выделена длинная строчка  и адрес красным

39

Re: Нужно автоматически создать отдельный файл doc на каждого из списка

For w = Doc2.Footnotes(1).Range.Words.Count To Doc2.Footnotes(1).Range.Words.Count - 5 Step -1
                                    Set wr = Doc2.Footnotes(1).Range.Words(w)
                                    With Doc2.Footnotes(1).Range.Words(w).Hyperlinks
                                        .Add Doc2.Footnotes(1).Range.Words(w), "mailto:maximmurmansk@mail.ru"
                                    End With
                                Next w

40

Re: Нужно автоматически создать отдельный файл doc на каждого из списка

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

41

Re: Нужно автоматически создать отдельный файл doc на каждого из списка

Изменил шаблон Normal, теперь создаются с переносом, а можно ли как-нибудь предыдущие автоматом исправить?

42

Re: Нужно автоматически создать отдельный файл doc на каждого из списка

Такой момент, в списке есть одинаковые имена, и конечно скрипт перезаписывает одинаковые файлы, то есть остается только последний, можно как-то подсказать ему оставлять все файлы????

43

Re: Нужно автоматически создать отдельный файл doc на каждого из списка

Вроде заканчиваю с созданием базы, но первые папки с файлами остались без автоматической расстановки переносов, можно как-то пакетно это исправить, вручную несколько тысяч файлов очень трудоемко. Спасибо за любую подсказку.