Ошибка при автоматизации формы письма с помощью VBA

Question

Моя цель - создать электронную таблицу, которая будет подавать информацию в письмо формы, создать новую папку, затем сохранить письмо в новой папке и повторить.

Приведенный ниже код завершает одну итерацию, нозапускается ошибка во втором цикле

сбой удаленного вызова процедуры

Я думаю, что это проблема с повторным открытием шаблона при втором запуске.

Public Sub WordFindAndReplace()
    Dim ws As Worksheet, msWord As Object, itm As Range, fileName As String, Path As String


    Set ws = ActiveSheet
    Set msWord = CreateObject("Word.Application")

    Set objdoc = msWord.Documents.Add



    For i = 1 To 4

    fileName = Cells(i, 4).Value
     Path = "C:\Users\jarafat\Desktop\Variation1\" & fileName & "\" & fileName & ".docx"

If Len(Dir("C:\Users\jarafat\Desktop\Variation1\" & fileName, vbDirectory)) = 0 Then
  MkDir "C:\Users\jarafat\Desktop\Variation1\" & fileName
  End If

    With msWord
        .Visible = True
        .Documents.Open "C:\Users\jarafat\Desktop\Variation1\VariationTemplate1.docx"
        .Activate



        With .Activedocument.Content.Find
            .ClearFormatting
            .Replacement.ClearFormatting

            .Text = "#address"
            .Replacement.Text = ws.Cells(i, 1).Value

            .Forward = True
            .Wrap = 1               'wdFindContinue (WdFindWrap Enumeration)
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False

            .Execute Replace:=2     'wdReplaceAll (WdReplace Enumeration)
        End With

        With .Activedocument.Content.Find
            .ClearFormatting
            .Replacement.ClearFormatting

            .Text = "#address1"
            .Replacement.Text = ws.Cells(i, 2).Value

            .Forward = True
            .Wrap = 1               'wdFindContinue (WdFindWrap Enumeration)
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False

            .Execute Replace:=2     'wdReplaceAll (WdReplace Enumeration)
        End With

        With .Activedocument.Content.Find
            .ClearFormatting
            .Replacement.ClearFormatting

            .Text = "#Description"
            .Replacement.Text = ws.Cells(i, 3).Value

            .Forward = True
            .Wrap = 1               'wdFindContinue (WdFindWrap Enumeration)
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False

            .Execute Replace:=2     'wdReplaceAll (WdReplace Enumeration)
        End With

        With msWord.Activedocument

        .SaveAs Path
        End With

        .Quit SaveChanges:=True
   End With
Next i
End Sub

Answer 1

В дополнение к решению Синди ...

Вместо того, чтобы повторять это несколько раз с небольшими вариациями:

  With .Activedocument.Content.Find
        .ClearFormatting
        .Replacement.ClearFormatting

        .Text = "#address"
        .Replacement.Text = ws.Cells(i, 1).Value

        .Forward = True
        .Wrap = 1               'wdFindContinue (WdFindWrap Enumeration)
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False

        .Execute Replace:=2     'wdReplaceAll (WdReplace Enumeration)
    End With

, вы можете сделать отдельную подпрограмму:

Sub ReplaceText(doc As Object, findWhat, replaceWith)
      With doc.Content.Find
            .ClearFormatting
            .Replacement.ClearFormatting

            .Text = findWhat
            .Replacement.Text = replaceWith

            .Forward = True
            .Wrap = 1         'wdFindContinue (WdFindWrap Enumeration)
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False

            .Execute Replace:=2  'wdReplaceAll (WdReplace Enumeration)
      End With
End sub

... и вызывать его из своего цикла

Dim doc
With msWord
    .Visible = True
    Set doc = .Documents.Open("C:\Users\jarafat\Desktop\Variation1\VariationTemplate1.docx")

    ReplaceText doc, "#address", ws.Cells(i, 1).Value
    ReplaceText doc, "#address1", ws.Cells(i, 2).Value
    ReplaceText doc, "#Description", ws.Cells(i, 3).Value
    'etc

Answer 2

Проблема возникает из-за того, что приложение Word выходит из цикла.Так что он больше не доступен для второго (и последующих) циклов:

    .Quit SaveChanges:=True
  End With
Next i

Вам нужно сделать это так, и это хорошая идея, чтобы привыкнуть правильно выпускать объекты (равные Nothing) также для внешних приложений.

  End With
Next i
msWord.Quit SaveChanges:=True
Set msWord = Nothing

Я также рекомендую объявлять и использовать объект Document вместо того, чтобы полагаться на ActiveDocument.Всегда есть вероятность, что активный документ не тот, который вы ожидаете.Например:

'At the beginning of the code
Dim doc as Object
'More code...
Set doc = .Documents.Open "C:\Users\jarafat\Desktop\Variation1\VariationTemplate1.docx"
'No need to activate, now...
'Activate
With doc.Content.Find
  'And so on until...
  .SaveAs Path
  'You're done with the document, so release the object
  Set doc = Nothing
End With