将文件保存在指定的文件夹中

Question

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 & 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") & "_" & .DataFields("Name") & "_Test"
      End With
      .Execute Pause:=False
    End With
    StrName = Trim(StrName)
    With ActiveDocument
      .SaveAs2 FileName:=StrFolder & StrName & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
      .PrintOut Copies:=1
      .Close SaveChanges:=False
    End With
  Next i
End With
Application.ScreenUpdating = True
End Sub

该代码将一个连续的字母分成单独的文件，将它们另存为pdf并开始打印。

宏将所有文件保存在同一文件夹中，我必须手动将每个文件移动到指定文件夹（每个文件都有一个自己的文件夹，名称为代码中的“编号”）。

是否可以直接将文件保存到目标文件夹中？

Answer 1

我会这样做：

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 & "General" 'or whatever you want
    numGen = numGen + 1
End If

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

此函数将 return 给定起始文件夹的任何匹配文件夹的路径（包括在子文件夹中搜索）。 Returns 如果不匹配则为空字符串。

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 & "\"
        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

Answer 2

您的代码源自 将邮件合并输出发送到单个文件 文章 Mailmerge 提示与技巧 线程，位于 https://www.msofficeforums.com/mail-merge/21803-mailmerge-tips-tricks.html.

那篇文章包含设置保存路径的代码，并告诉你如何使用它...

将文件保存在指定的文件夹中

Save files in designated folders

vba

ms-word