бесконечный цикл в коде VBA (не уверен, где)

Question

Я очень плохо знаком с VBA и не уверен, что делаю неправильно, последовательность задач, которые я хочу выполнить, правильная, но я не уверен, почему задача не завершается.

Я думаю, что проблема возникает в какой-то момент после этой строки "LastRow = .Range (" G9999 "). End (xlUp) .Row" Определить последнюю строку в таблице для CustRow = 8 To LastRow ", но яЯ не уверен, что с ним не так.

Option Explicit

Sub CreateWordDocuments()
Dim CustRow, CustCol, LastRow, TemplRow As Long
Dim DocLoc, TagName, TagValue, TemplName, FileName As String
Dim WordDoc, WordApp As Object
Dim WordContent As Word.Range
With Sheet1

  If .Range("B3").Value = Empty Then
    MsgBox "Please select a template from the drop down list"
    .Range("F3").Select
    Exit Sub
  End If
    TemplRow = .Range("B3").Value 'Set Template Row
    TemplName = .Range("F3").Value 'Set Template Name
    DocLoc = Sheet9.Range("F" & TemplRow).Value 'Word Document Filename

    'Open Word Template
    On Error Resume Next 'If Word is already running
    Set WordApp = GetObject("Word.Application")
    If Err.Number <> 0 Then
    'Launch a new instance of Word
    Err.Clear
    'On Error GoTo Error_Handler
    Set WordApp = CreateObject("Word.Application") 'launches word application
    WordApp.Visible = True 'Make the application visible to the user
    End If


    LastRow = .Range("G9999").End(xlUp).Row  'Determine Last Row in Table
        For CustRow = 8 To LastRow
            Set WordDoc = WordApp.Documents.Open(FileName:=DocLoc, ReadOnly:=False) 'Open Template
                TagName = .Cells(CustRow, 7).Value 'Tag Name
                TagValue = .Cells(CustRow, 8).Value 'Tag Value
                    With WordDoc.Content.Find
                        .Text = TagName
                        .Replacement.Text = TagValue
                        .Wrap = wdFindContinue
                        .Execute Replace:=wdReplaceAll 'Find & Replace all instances
                    End With

        Next CustRow

    FileName = ThisWorkbook.Path & "\" & .Range("H8").Value & "_" & ".docx"
    WordDoc.SaveAs FileName
    WordDoc.Close
    WordApp.Quit

End With
End Sub

Последовательность, которую я хотел бы пройти, выглядит следующим образом:

1. Открыть шаблон, который я сделал с пробелами, которые необходимо заполнить, открыт

2. Затем все пробелы заменяются требуемым текстом

3. документ сохраняется под другим именем, поэтому шаблон остается неизменным

4. тогда я могу просто зайти в папку и открыть новый текстовый документ, чтобы внести какие-либо дальнейшие изменения

Если у кого-нибудь есть какие-либо предложения по оптимизации этого кода, он будетприветствовать, как я уже говорил, это моя первая попытка чего-либо такого масштаба.

Заранее спасибо,

Cal

Answer 1

Первая проблема, которая у вас возникла, это не бесконечный цикл, а утечка памяти, которая возникает здесь:

For CustRow = 8 To LastRow
    Set WordDoc = WordApp.Documents.Open(FileName:=DocLoc, ReadOnly:=False) 'Open Template

    <snip>

Next CustRow

FileName = ThisWorkbook.Path & "\" & .Range("H8").Value & "_" & ".docx"
WordDoc.SaveAs FileName
WordDoc.Close

По сути, вы открываете новую копию рабочей книги для каждый экземпляр цикла. если LastRow = 18, то вы открываете 10 копий рабочей книги, затем сохраните и закройте последнюю одну. Если LastRow = 1008, то, возможно, ваш компьютер зависает. (Это также означает, что каждая замена выполняется только для одного документа!)

Чтобы это исправить, просто переместите строку Set WordDoc = WordApp.Documents.Open(FileName:=DocLoc, ReadOnly:=False) 'Open Template до цикла For. Таким образом, вы открываете 1 копию шаблона, вносите в него всех замен и затем сохраняете его снова.

вторая проблема заключается в том, что Document.Content.Find не ищет заголовок (или нижний колонтитул), а только основное текстовое тело. Вам нужно будет заглянуть в Document.Section.Header.Range.Text, чтобы разобраться с этим. Полный код ниже:

Option Explicit

Sub CreateWordDocuments()
    'Putting "As <Type>" at the end ONLY sets the Type of the last Variable.  Everything else is Variant
    Dim CustRow As Long, CustCol As Long, LastRow As Long, TemplRow As Long
    Dim DocLoc As String, TagName As String, TagValue As String, TemplName As String, FileName As String
    Dim WordDoc As Object, WordApp As Object
    'WordContent is not used

    With Sheet1
        If .Range("B3").Value = Empty Then
            MsgBox "Please select a template from the drop down list"
            .Range("F3").Select
            Exit Sub
        End If

        TemplRow = .Range("B3").Value 'Set Template Row
        TemplName = .Range("F3").Value 'Set Template Name
        DocLoc = Sheet9.Range("F" & TemplRow).Value 'Word Document Filename

        'Open Word Template
        On Error Resume Next 'If Word is already running
        Set WordApp = GetObject("Word.Application")
        If Err.Number <> 0 Then
            'Launch a new instance of Word
            Err.Clear
            'On Error GoTo Error_Handler
            Set WordApp = CreateObject("Word.Application") 'launches word application
            WordApp.Visible = True 'Make the application visible to the user
        End If
        On Error GoTo 0 'Let us know if there are any errors after this!


        LastRow = .Cells(.Rows.Count, 7).End(xlUp).Row 'Determine Last Row in Table

        Set WordDoc = WordApp.Documents.Open(FileName:=DocLoc, ReadOnly:=False) 'Open Template ONCE

        For CustRow = 8 To LastRow
            TagName = .Cells(CustRow, 7).Value 'Tag Name
            TagValue = .Cells(CustRow, 8).Value 'Tag Value

            'Replace in Body
            With WordDoc.Content.Find
                .Text = TagName
                .Replacement.Text = TagValue
                .Wrap = wdFindContinue
                .Execute Replace:=wdReplaceAll 'Find & Replace all instances
            End With

            'Replace in Header
            With WordDoc.Sections(1).Headers(wdHeaderFooterPrimary).Range
                .Text = Replace(.Text, TagName, TagValue)
            End With

            'Replace in Footer
            With WordDoc.Sections(1).Footers(wdHeaderFooterPrimary).Range
                .Text = Replace(.Text, TagName, TagValue)
            End With

        Next CustRow

        FileName = ThisWorkbook.Path & "\" & .Range("H8").Value & "_" & ".docx"
        WordDoc.SaveAs FileName
        WordDoc.Close
        WordApp.Quit

    End With
End Sub