Блог

Это код, полученный из советов и рекомендаций по слиянию почты.

 Sub Merge_To_Individual_Files()
Application.ScreenUpdating = False
Dim StrFolder As String, StrName As String, MainDoc As Document, i As Long, j As Long
Set MainDoc = ActiveDocument
With MainDoc
  StrFolder = .Path amp; Application.PathSeparator
  For i = 1 To .MailMerge.DataSource.RecordCount
    With .MailMerge
      .Destination = wdSendToNewDocument
      .SuppressBlankLines = True
      With .DataSource
        .FirstRecord = i
        .LastRecord = i
        .ActiveRecord = i
        If Trim(.DataFields("Name")) = "" Then Exit For
        StrName = .DataFields("Number") amp; "_" amp; .DataFields("Name") amp; "_Test"
      End With
      .Execute Pause:=False
    End With
    StrName = Trim(StrName)
    With ActiveDocument
      .SaveAs2 FileName:=StrFolder amp; StrName amp; ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
      .PrintOut Copies:=1
      .Close SaveChanges:=False
    End With
  Next i
End With
Application.ScreenUpdating = True
End Sub
 

Код разделяет серийный номер на отдельные файлы, сохраняет их в формате pdf и запускает печать.

Макрос сохраняет все файлы в одной папке, и я должен переместить каждый файл в указанную папку вручную (у каждого файла есть своя папка с «Номером» из кода в качестве имени).

Возможно ли сохранить файлы непосредственно в намеченной папке?

Я бы сделал что-то вроде этого:

 Dim num, numGen as long, f, StrFolder As String
'...
'...
num = .DataFields("Number") 'capture the value in the With .DataSource block
'...
'...

'check if the destination folder exists
f = FindFolder(StrFolder, CStr(num)) 'returns folder path if exists

If Len(f) = 0 Then
    'no match was found - use a generic folder
    f =   StrFolder amp; "General" 'or whatever you want
    numGen = numGen   1
End If

.SaveAs2 FileName:= f amp; _
         Application.PathSeparator amp; StrName amp; ".pdf", _
         FileFormat:=wdFormatPDF, AddToRecentFiles:=False
'...
'...
'Notify that some files need to be moved
If numGen > 0 Then
    Msgbox numGen amp; " files were saved to 'General' folder"
End If
 

Эта функция вернет путь к любой соответствующей папке, в которой указана начальная папка для начала (включает поиск во вложенных папках). Возвращает пустую строку, если совпадений нет.

 Function FindFolder(StartAt As String, ByVal folderName As String) As String
    Dim colFolders As New Collection, sf, path, fld, fso
    Set fso = CreateObject("scripting.filesystemobject")
    colFolders.Add StartAt
    Do While colFolders.Count > 0
        fld = colFolders(1)
        colFolders.Remove 1
        If Right(fld, 1) <> "" Then fld = fld amp; ""
        For Each sf In fso.getfolder(fld).subfolders
            If sf.Name = folderName Then
                FindFolder = sf.path
                Exit Function
            Else
                colFolders.Add sf
            End If
        Next sf
    Loop
End Function
 

Ваш код получен из статьи «Отправить вывод Mailmerge в отдельные файлы» в разделе «Советы и рекомендации Mailmerge» по адресу https://www.msofficeforums.com/mail-merge/21803-mailmerge-tips-tricks.html .

В этой статье содержится код для настройки пути сохранения и рассказывается, как его использовать…