При слиянии в word из excel сохранить в отдельный файл с названиями по определенному полю

      
      if FSO.FileExists( FSO.BuildPath (wDir, fName &".docx")) then
        for ii=1 to 99 step 1
          if not FSO.FileExists(FSO.BuildPath (wDir, fName & " ("& ii &").docx")) then
            fName = fName & " ("& ii &")"
            exit for
          end if
        next
      end if

Option Explicit
 
Dim wrd, aa, aColNums
Dim spath, sname, irow, icol, srow, zrow, ii, ns, nn
Dim xm(66) As String 'массив того, что искать в word-шаблоне, с запасом
Dim ym(66) As Long 'массив номеров колонок Escel-файла для замены
 
Sub m220419word()
spath = Excel.ActiveWorkbook.Path & "\"
 
Set wrd = CreateObject("Word.Application")
wrd.Visible = False ''True
'лучше потом поменять на false, чтобы Word  открывался невидимым
 
With Excel.ActiveWorkbook.Worksheets(1) '''''''''''''
aa = .UsedRange.Value
End With
 
ns = 0
Dim r1, r1k, c1, c1k
c1k = UBound(aa, 2)
c1 = LBound(aa, 2)
r1k = UBound(aa, 1)
r1 = LBound(aa, 1)
''6             1             10            10
 
For icol = c1 To c1k
srow = "@" & aa(1, icol)
If Len(srow) > 1 Then
Debug.Print icol, srow
ns = ns + 1: xm(ns) = srow: ym(ns) = icol
End If
'Число строк заголовков, которые пропускать
 
Next icol
Debug.Print ns, xm(1), ym(1)
''цикл по строкам
For irow = r1 + 1 To r1k
xlRow2Wrd
Next irow
 
wrd.Quit
'закроем Word
Set wrd = Nothing
'очистим объекты
''MsgBox "Я кончила! Твоя очередь."
Debug.Print Now
End Sub
 
Sub xlRow2Wrd()
With wrd.documents.Open(spath & "исх19.dotx")
For ii = 1 To ns
Debug.Print ii, ym(ii), xm(ii)
.Content.Find.Execute xm(ii), False, False, False, False, False, True, 1, False, aa(irow, ym(ii)), 2
Next
sname = aa(irow, 1)
sname = Replace(sname, """", "_")
.SaveAs2 spath & sname & ".docx", 12
.Close
End With
End Sub

fName = aa(iRow,1)

dim xls, wrd, FSO, Sha, xDir, wDir, sDir, xF, sFiles, xFiles, aa, aWhatFind, aColNums
  Const hdrRows=2 'Число строк заголовков, которые пропускать
  aWhatFind=Array("Имя файла","@Дата ENG","@Дата RUS","«Компания_ENG»","«Компания_RUS»","«Президент_ENG»","«Президент_RUS»","«ИПфизик_ENG»","«ИПфизик_RUS»","«ФИО_ENG»","«ФИО_RUS»","«Номер_и_дата_договора_ENG»","«Номер_и_дата_договора_RUS»","«Обязанности_ENG»","«Обязанности_RUS»","«Период_ENG»","«Период_RUS»","«Сумма_ENG»","«Сумма_RUS»") 'массив того, что искать в word-шаблоне
  aColNums =Array(1,12,13,7,6,8,9,5,4,2,3,14,15,11,10,16,17,18,19) 'массив номеров колонок Escel-файла для замены
  Set FSO = CreateObject("Scripting.FileSystemObject") 
  
  xDir = FSO.GetAbsolutePathname("") ' xlsx ищем в текущей папке
  sDir = xDir 'папка, где лежат шаблоны, пока пишем текущую папку 
  wDir = xDir 'папка, куда кладём готовый результат. пока в текущую
  with  CreateObject("Shell.Application")
    Set sFiles = .NameSpace(sDir).Items() 'всё что есть в папке шаблонов
    Set xFiles = .NameSpace(xDir).Items() 'пока то же
  end with
  sFiles.Filter 64, "*.dotx" 'смотрим в папке шаблонов на файлы с такой маской.
  if sFiles.Count < 1 Then 'ФАЙЛОВ НЕТ
    wsh.echo "Нет шаблонов В папке " & wDir
    wsh.quit
  end if
  xFiles.Filter 64, "*.xlsx" 'смотрим в папке xlsx только на файлы с такой маской.
  if xFiles.Count < 1 Then 'ФАЙЛОВ НЕТ
    wsh.echo "Нет файлов *.xlsx В папке " & xDir
    wsh.quit
  end if
 
  Set xls = CreateObject("Excel.Application")
  xls.Visible = True 'лучше потом поменять на false, чтобы Excel открывался невидимым
  Set wrd = CreateObject("Word.Application")
  wrd.Visible = True 'лучше потом поменять на false, чтобы Word  открывался невидимым
 
  for each xF in xFiles 'переберём все xlsx файлы
    With xls.WorkBooks.Open(xf.Path)
      aa = .Sheets(1).UsedRange.Value
      .Close
    end with
    for iRow = HdrRows+1 to uBound(aa) step 1
      xlRow2Wrd() ' обработаем каждую строку
    next
  next
  xls.quit 'закроем Excel
  wrd.quit 'закроем Word
  Set wrd=Nothing: Set xls=Nothing: Set FSO=Nothing: Set Sha=Nothing
  Set sFiles=Nothing: Set xFiles=Nothing: Set xF=Nothing 'очистим объекты
  wsh.echo "Я кончила! Твоя очередь." 
  wsh.quit
  
  Sub xlRow2Wrd()
  dim fName
  const Repl=""".,&@#№'<>"
  for each sF in sFiles
    with wrd.documents.Open(sF.Path)
      for ii = 0 to uBound(aColNums) step 1
        if aColNums(ii) <= uBound(aa,2) then
          .Content.Find.Execute aWhatFind(ii), False, False, False, False, False, True, 1, False, aa(iRow,aColNums(ii)), 2
        end if
      next
      fName = aa(iRow,aColNums(0))
      for ii=1 to Len(Repl) step 1
        fName = replace(fName,Mid(repl,ii,1),"")
      next
      .SaveAs FSO.BuildPath (wDir, fName),12 
      .Close
    end with
  next
end sub

  wStr = aWhatFind(ii) 'то_что_ищем в word-шаблоне  = заведомо маленькое и заведомо НЕ ПОПАДАЮЩЕЕСЯ в том_на_что_меняем
  xStr = aa(iRow,aColNums(ii)) 'то_на_что_меняем (из excel-таблицы). Может быть велико
  While Len(xStr) > 250 'до тех пор пока то_на_что_меняем > 250 символов
    'меняем в цикле то_что_ищем на обрезок того_на_что_меняем + то_что_ищем на хвосте
    .Content.Find.Execute wStr, False, False, False, False, False, True, 1, False, left(xStr,250-len(wStr)) & wStr, 2 
    xStr = mid(xStr,251-len(wStr)) 'отрезаем то, что уже вставили от начала того_на_что_меняем
  loop
  .Content.Find.Execute wStr, False, False, False, False, False, True, 1, False, xStr, 2 'довставляем остаток

dim nc as long
dim aWhatFind(0 to 99) as String  ''с запасом + небольшое изменение в блоке замены
nc= 1         :aWhatFind(nc) = "Имя файла"
nc= 12        :aWhatFind(nc) = "@Дата ENG"
nc= 13        :aWhatFind(nc) = "@Дата RUS"
nc= 7         :aWhatFind(nc) = "«Компания_ENG»"
nc= 6         :aWhatFind(nc) = "«Компания_RUS»"
nc= 8         :aWhatFind(nc) = "«Президент_ENG»"
nc= 9         :aWhatFind(nc) = "«Президент_RUS»"
nc= 5         :aWhatFind(nc) = "«ИПфизик_ENG»"
nc= 4         :aWhatFind(nc) = "«ИПфизик_RUS»"
nc= 2         :aWhatFind(nc) = "«ФИО_ENG»"
nc= 3         :aWhatFind(nc) = "«ФИО_RUS»"
nc= 14        :aWhatFind(nc) = "«Номер_и_дата_договора_ENG»"
nc= 15        :aWhatFind(nc) = "«Номер_и_дата_договора_RUS»"
nc= 11        :aWhatFind(nc) = "«Обязанности_ENG»"
nc= 10        :aWhatFind(nc) = "«Обязанности_RUS»"
nc= 16        :aWhatFind(nc) = "«Период_ENG»"
nc= 17        :aWhatFind(nc) = "«Период_RUS»"
nc= 18        :aWhatFind(nc) = "«Сумма_ENG»"
nc= 19        :aWhatFind(nc) = "«Сумма_RUS»"

'purpose: save each letter generated after mail merge in a separate file
'         with the file name equal to first line of the letter.
'
'1. Before you run a mail merge make sure that in the main document you will 
'   end your letter with a Section Break (this can be found under 
'   Page Layout/Breaks/Section Break Next Page)
'2. Furthermore the first line of your letter contains the proposed file name
'   and put an enter after it. Make the font of the filename white, to make it 
'   is invisible to the receiver of the letter. You can also include a folder 
'   name if you like.
'3. Run the mail merge as usual. A file which contains all the letters is 
'   generated.
'4. Add this module to the generated mail merge file. Use Alt-F11 to go to the 
'   visual basic user interface, right click in the left pane on the generated
'   file and click on Import File and import this file
'5. save the generate file with all the letters as ‘Word Macro Enabled doc 
'   (*.docm)’.
'6. close the file.
'7. open the file again, click allow content when a warning about macro's is 
'   shown.
'8. execute the macro with the name SaveRecsAsFiles
 
 
Sub SaveRecsAsFiles()
    ' Convert all sections to Subdocs
    AllSectionsToSubDoc ActiveDocument
    'Save each Subdoc as a separate file
    SaveAllSubDocs ActiveDocument
End Sub
 
Private Sub AllSectionsToSubDoc(ByRef doc As Word.Document)
    Dim secCounter As Long
    Dim NrSecs As Long
    NrSecs = doc.Sections.Count
    'Start from the end because creating
    'Subdocs inserts additional sections
    For secCounter = NrSecs - 1 To 1 Step -1
        doc.Subdocuments.AddFromRange _
          doc.Sections(secCounter).Range
    Next secCounter
End Sub
 
Private Sub SaveAllSubDocs(ByRef doc As Word.Document)
    Dim subdoc As Word.Subdocument
    Dim newdoc As Word.Document
    Dim docCounter As Long
    Dim strContent As String, strFileName As String
 
    docCounter = 1
    'Must be in MasterView to work with
    'Subdocs as separate files
    doc.ActiveWindow.View = wdMasterView
    For Each subdoc In doc.Subdocuments
        Set newdoc = subdoc.Open
        'retrieve file name from first line of letter.
        strContent = newdoc.Range.Text
        strFileName = Mid(strContent, 1, InStr(strContent, Chr(13)) - 1)
        'Remove NextPage section breaks
        'originating from mailmerge
        RemoveAllSectionBreaks newdoc
        With newdoc
            .SaveAs FileName:=strFileName
            .Close
        End With
        docCounter = docCounter + 1
    Next subdoc
End Sub
 
Private Sub RemoveAllSectionBreaks(doc As Word.Document)
    With doc.Range.Find
        .ClearFormatting
        .Text = "^b"
        With .Replacement
            .ClearFormatting
            .Text = ""
        End With
        .Execute Replace:=wdReplaceAll
    End With
End Sub

.Content.Find.Execute aWhatFind(ii), False, False, False, False, False, True, 1, False, aa(iRow,aColNums(ii)), 2

  wStr = aWhatFind(ii) 'то_что_ищем в word-шаблоне  = заведомо маленькое и заведомо НЕ ПОПАДАЮЩЕЕСЯ в том_на_что_меняем
  xStr = aa(iRow,aColNums(ii)) 'то_на_что_меняем (из excel-таблицы). Может быть велико
  Do While Len(xStr) > 250 'до тех пор пока то_на_что_меняем > 250 символов
    'меняем в цикле то_что_ищем на обрезок того_на_что_меняем + то_что_ищем на хвосте
    .Content.Find.Execute wStr, False, False, False, False, False, True, 1, False, left(xStr,250-len(wStr)) & wStr, 2 
    xStr = mid(xStr,251-len(wStr)) 'отрезаем то, что уже вставили от начала того_на_что_меняем
  loop
  .Content.Find.Execute wStr, False, False, False, False, False, True, 1, False, xStr, 2 'довставляем остаток

dim xls, wrd, FSO, Sha, xDir, wDir, sDir, xF, sFiles, xFiles, aa, aWhatFind, aColNums, wStr, xStr
  Const hdrRows=2 'Число строк заголовков, которые пропускать
  aWhatFind=Array("Имя файла","@Дата ENG","@Дата RUS","«Компания_ENG»","«Компания_RUS»","«Президент_ENG»","«Президент_RUS»","«ИПфизик_ENG»","«ИПфизик_RUS»","«ФИО_ENG»","«ФИО_RUS»","«Номер_и_дата_договора_ENG»","«Номер_и_дата_договора_RUS»","«Обязанности_ENG»","«Обязанности_RUS»","«Период_ENG»","«Период_RUS»","«Сумма_ENG»","«Сумма_RUS»") 'массив того, что искать в word-шаблоне
  aColNums =Array(1,12,13,7,6,8,9,5,4,2,3,14,15,11,10,16,17,18,19) 'массив номеров колонок Escel-файла для замены
  Set FSO = CreateObject("Scripting.FileSystemObject") 
  
  xDir = FSO.GetAbsolutePathname("") ' xlsx ищем в текущей папке
  sDir = xDir 'папка, где лежат шаблоны, пока пишем текущую папку 
  wDir = xDir 'папка, куда кладём готовый результат. пока в текущую
  with  CreateObject("Shell.Application")
    Set sFiles = .NameSpace(sDir).Items() 'всё что есть в папке шаблонов
    Set xFiles = .NameSpace(xDir).Items() 'пока то же
  end with
  sFiles.Filter 64, "*.dotx" 'смотрим в папке шаблонов на файлы с такой маской.
  if sFiles.Count < 1 Then 'ФАЙЛОВ НЕТ
    wsh.echo "Нет шаблонов В папке " & wDir
    wsh.quit
  end if
  xFiles.Filter 64, "*.xlsx" 'смотрим в папке xlsx только на файлы с такой маской.
  if xFiles.Count < 1 Then 'ФАЙЛОВ НЕТ
    wsh.echo "Нет файлов *.xlsx В папке " & xDir
    wsh.quit
  end if
 
  Set xls = CreateObject("Excel.Application")
  xls.Visible = True 'лучше потом поменять на false, чтобы Excel открывался невидимым
  Set wrd = CreateObject("Word.Application")
  wrd.Visible = True 'лучше потом поменять на false, чтобы Word  открывался невидимым
 
  for each xF in xFiles 'переберём все xlsx файлы
    With xls.WorkBooks.Open(xf.Path)
      aa = .Sheets(1).UsedRange.Value
      .Close
    end with
    for iRow = HdrRows+1 to uBound(aa) step 1
      xlRow2Wrd() ' обработаем каждую строку
    next
  next
  xls.quit 'закроем Excel
  wrd.quit 'закроем Word
  Set wrd=Nothing: Set xls=Nothing: Set FSO=Nothing: Set Sha=Nothing
  Set sFiles=Nothing: Set xFiles=Nothing: Set xF=Nothing 'очистим объекты
  wsh.echo "Я кончила! Твоя очередь." 
  wsh.quit
  
  Sub xlRow2Wrd()
  dim fName
  const Repl=""".,&@#№'<>"
  for each sF in sFiles
    with wrd.documents.Open(sF.Path)
      for ii = 0 to uBound(aColNums) step 1
        if aColNums(ii) <= uBound(aa,2) then
          wStr = aWhatFind(ii) 'то_что_ищем в word-шаблоне  = заведомо маленькое и заведомо НЕ ПОПАДАЮЩЕЕСЯ в том_на_что_меняем
          xStr = aa(iRow,aColNums(ii)) 'то_на_что_меняем (из excel-таблицы). Может быть велико
          do While Len(xStr) > 250 'до тех пор пока то_на_что_меняем > 250 символов
            'меняем в цикле то_что_ищем на обрезок того_на_что_меняем + то_что_ищем на хвосте
            .Content.Find.Execute wStr, False, False, False, False, False, True, 1, False, left(xStr,250-len(wStr)) & wStr, 2 
            xStr = mid(xStr,251-len(wStr)) 'отрезаем то, что уже вставили от начала того_на_что_меняем
          loop
          .Content.Find.Execute wStr, False, False, False, False, False, True, 1, False, xStr, 2 'довставляем остаток
        end if
      next
      fName = aa(iRow,aColNums(0))
      for ii=1 to Len(Repl) step 1
        fName = replace(fName,Mid(repl,ii,1),"")
      next
      .SaveAs FSO.BuildPath (wDir, fName),12 
      .Close
    end with
  next
end sub