Вы не вошли. Пожалуйста, войдите или зарегистрируйтесь.
Форум Microsoft Word » Автоматизация » Нужно автоматически создать отдельный файл doc на каждого из списка
Страницы 1
Чтобы отправить ответ, вы должны войти или зарегистрироваться
Приветствую! Имеется один большой список doc файл - ФИО и данные о занимаемой должности и тд, нужно на каждого автоматически создать отдельный файл лучше в отдельном каталоге с данными из списка
Выложите образец файла
Да, спасибо за отклик, вот фрагмент
В принципе ни чего сложного, но код напишу завтра с утра, сегодня уже поздно
спасибо, буду ждать
Извиняюсь как там с кодом??
Выкладываю
В общем песня такая.
I. Импортируете вложенный модуль в проект Normal
II. Макрос называется SaveFiles
III. Описание макроса
1. Открываете файл оригинал
2. Выделяете определенное количество фамилий (весь файл выделять не рекомендую)
3. Вводите имя основной папки куда треба сохранить файлы
4. Во время создания файлов в файле-оригинале готовые фамилии будут выделяться красным.
5. В каталога создается папка с 1-й буквой фамилии, а в ней отдельная папка на каждую фамилию
6. Дождитесь завершения макроса
Для продолжения работы выделите другие фамилии не отмеченные красным.
P.S. Прежде чем работать с основным файлом потренируйтесь на фрагментах.
Пишите если возникнут вопросы
Вот доработанный модуль
Извините, с чего начать у меня Word 2003? Где найти проект?
Извините, вроде нашел инструкцию
Спасибо, вроде разобрался, а можно ли автоматизировать и не подтверждать содание каждого файла?
В посте №9 выложен модернизированный модуль. На Вашем фрагменте у меня работает только в путь. Удалите старый модуль и импортируйте новый.
Файлы почему-то создает в папке Мои документы и каждый раз просит подтверждение создания каждого файла.
А разобрался, файлы будут создаваться в папке которую я укажу.
Ну вот все равно просит подтверждения, можно ли что сделать?
Сделайте так:
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 и проверьте сохраненные файлы
Извините, что-то не так, файлы все создаются в первой папке, а в остальных пусто и все равно просит подтверждение создания файлов
структуру папок создает правильно, но просит указать папку для файла, вот бы сам все делал
Попробуйте заменить строку
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Выдает ошибку
Compile error Named argument not found
и подчеркнуто CompatibilityMode:=
Тогда оставьте только
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
Извините, оставил только одну строку, все работает автоматом, но имена самих файлов в папках всегда одинаковый - только фамилия, а нужно чтобы было как в списке, это реально?
Реально, но хлопотно, придется писать дополнительно код удаления точек между инициалами и запятых, потому что в имени файла, точка разделяет имя файла и расширение. Код проверки и составления грамотного имени существенно уменьшит скорость работы макроса. Тем более под каждую фамилию есть своя папочка.
Сказали можно без папок но название файлов должно быть как в списке, то есть первая папка с букой и достаточно - в ней только файлы без доп папок с именем, если есть время попробуйте пожалуйста
Извините если у Вас есть минутка попробуйте пожалуйста,
нужна папка с первой буквой и в ней все файлы с названием из списка на эту букву, буду очень признателен
Замените весь старый код на новый
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Спасибо скрипт работает, конечно если не большой объем фамилий, выделяю по несколько страниц, иначе ошибка и ссылка на формулу i=i+1
Но по чуть-чуть получается.
Вот еще понадобилось в конце каждого файла добавить строчку -
______________________________________________
Для получения полной архивной справки по этому че-ловеку, а также фотоматериалов с ним, пишите архи-вариусу: maximmurmansk@mail.ru
Подскажите самый простой вариант или может в скрипт добавить, спасибо за помощь
Вот замена для процедуры 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В конце странице добавляется сноска с Вашим текстом
Надо заново все фамилии делать, а для уже сделанных придется скрипт писать, а это работа
Спасибо все получилось а как можно шрифт немного увеличить этой добавочной ссылки?
После строки
Doc2.Range.Footnotes.Add Doc2.Range(Doc2.Range.End - 1, Doc2.Range.End - 1), , _
"Для получения полной архивной справки по этому человеку, а также фотоматериалов с ним, пишите архивариусу: maximmurmansk@mail.ru"добавьте строку
Doc2.Range.Footnotes(1).Range.Font.Size = [размер шрифта]
Вы просто база знаний!
Еще маленькая прихоть, можно ли сделать чтобы мой адрес был как ссылка чтобы сразу написать письмо, вроде это как гиперссылка, если не ошибаюсь
Извините, если это сложно,может просто что-то посоветуете
в ворде есть поле, написано введите вопрос, напишите гиперссылка и отталкивайтесь оттуда
В тоже место куда вставляли строку
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, будет открываться окно электронной почты
Извините, можно чтобы подчеркнутым был только мой адрес, а то сложности возникают
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Извините вот код
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 WithSyntax error и выделена длинная строчка и адрес красным
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Огромное спасибо за помощь, но столкнулся с маленькой проблемой, в получаемых файлах не стоит расстановка переносов, можно ли теперь полученные файлы автоматически преобразовать и что нужно добавить в код, чтобы другие были с расстановкой.
Изменил шаблон Normal, теперь создаются с переносом, а можно ли как-нибудь предыдущие автоматом исправить?
Такой момент, в списке есть одинаковые имена, и конечно скрипт перезаписывает одинаковые файлы, то есть остается только последний, можно как-то подсказать ему оставлять все файлы????
Вроде заканчиваю с созданием базы, но первые папки с файлами остались без автоматической расстановки переносов, можно как-то пакетно это исправить, вручную несколько тысяч файлов очень трудоемко. Спасибо за любую подсказку.
Страницы 1
Чтобы отправить ответ, вы должны войти или зарегистрироваться
Форум Microsoft Word » Автоматизация » Нужно автоматически создать отдельный файл doc на каждого из списка