Перенос ячеек Excell в Microsoft Word

Я беру выполнение кода от кого-то с работы, я пытаюсь переместить определенные ячейки в электронной таблице Excel в документ Microsoft Word. В настоящее время перемещены три абзаца, однако я хочу добавить 4-й абзац, в котором *** представляет код, который я добавил.

Когда я пытаюсь запустить код после добавления строк, я получаю сообщение об ошибке «Запрошенный член коллекции не существует». Может ли кто-нибудь просмотреть код и увидеть, где я ошибаюсь?

Извините, я добавил весь блок кода, поэтому он длинный. Спасибо

Option Explicit
Option Compare Text


Sub Questionnaire_To_Word()

    Dim fd As FileDialog, wdDlg As Word.Dialog
    Dim bLeaveOpen As Boolean
    Dim strStartFolder As String
    Dim strQuestionnaire As String, strQuestionnairePath As String, strQuestionnaireFileName As String, strTemplate As String, strOutput As String
    Dim bQuestionnaireAlreadyOpen As Boolean
    Dim strTemplatePath As String
    Dim wbkInput As Workbook, docOutput As Word.Document, wdApp As New Word.Application
    Dim strOutputFileName As String
    Dim shtPC As Worksheet, shtGI As Worksheet, shtIG As Worksheet, shtIMP As Worksheet
    
    bLeaveOpen = (MsgBox("Do you want the Word document left open?", vbQuestion + vbYesNo + vbDefaultButton1, "MVP") = vbYes)
    strStartFolder = ThisWorkbook.Path
    
'prompt user to select questionnaire file
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    With fd
        .Filters.Clear
        .Filters.Add "Excel Files", "*.xls?", 1
        .Title = "Select questionnaire"
        .AllowMultiSelect = False
        .InitialFileName = strStartFolder & "\" 'set start folder
        If Not .Show() Then Exit Sub 'exit if user selected Cancel
    End With
    strQuestionnaire = fd.SelectedItems(1)
    strQuestionnairePath = Left(strQuestionnaire, InStrRev(strQuestionnaire, "\") - 1)
    strQuestionnaireFileName = Mid(strQuestionnaire, Len(strQuestionnairePath) + 2)
    Debug.Print "path: '" & strQuestionnairePath & "'"
    Debug.Print "file: '" & strQuestionnaireFileName & "'"
    
'prompt user to select Word template file
    With fd
        .Filters.Clear
        .Filters.Add "Word Files", "*.doc?", 1
        .Title = "Select Word template"
        .AllowMultiSelect = False
        .InitialFileName = strStartFolder & "\" 'set start folder
        If Not .Show() Then Exit Sub 'exit if user selected Cancel
    End With
    strTemplate = fd.SelectedItems(1)
    Set fd = Nothing
    
'open Word and load template - use plenty of DoEvents so Excel doesn't race ahead before Word is ready
    Application.StatusBar = "Opening Word ..."
    Set wdApp = New Word.Application
    DoEvents 'give Windows time to open Word
    Application.StatusBar = "Opening Word template"
    Set docOutput = wdApp.Documents.Open(Filename:=strTemplate, ReadOnly:=True)
    DoEvents
    wdApp.ActiveWindow.View.Type = wdNormalView 'VBA opens Word in an odd view that causes problems - change it to Normal view
    DoEvents
    
'open questionnaire if not already open
    Application.StatusBar = "Opening questionnaire ..."
    If IsWorkbookAlreadyOpen(strQuestionnaireFileName) Then
        Set wbkInput = Workbooks(strQuestionnaireFileName)
        bQuestionnaireAlreadyOpen = True
    Else
        Set wbkInput = Workbooks.Open(Filename:=strQuestionnaire, UpdateLinks:=False, ReadOnly:=True)
        bQuestionnaireAlreadyOpen = False
    End If
    Set shtPC = wbkInput.Worksheets("1")
    Set shtIG = wbkInput.Worksheets("2")
    Set shtGI = wbkInput.Worksheets("3")
    Set shtIMP = wbkInput.Worksheets("4")
    
'copy data over
'- you can either copy from Excel and paste/paste-special in Word (useful for copying tables with Excel's formatting)
'- or simply write it out in Word (uses formatting in Word)

    Application.ScreenUpdating = False
    docOutput.Bookmarks("Paragraph 1").Range.Text = shtIG.Range("F7").Value
    docOutput.Bookmarks("Paragraph 2").Range.Text = shtIG.Range("F9").Value
    docOutput.Bookmarks("Paragraph 3").Range.Text = shtIG.Range("F24").Value
    
*** docOutput.Bookmarks("Paragraph 4").Range.Text = shtPC.Range("G10").Value ***

'remove bookmarks
    docOutput.Bookmarks("Paragraph 1").Delete
    docOutput.Bookmarks("Paragraph 2").Delete
    docOutput.Bookmarks("Paragraph 3").Delete
    
*** docOutput.Bookmarks("Paragraph 4").Delete ***
    
'save output
    Application.ScreenUpdating = True
    wdApp.Visible = True 'bring Word to front
    wdApp.Activate
    strOutputFileName = wbkInput.Name
    strOutputFileName = Left(strOutputFileName, InStrRev(strOutputFileName, ".") - 1) & ".docx"
    Set wdDlg = wdApp.Dialogs(wdDialogFileSaveAs)
    With wdDlg
        .Name = wbkInput.Path & "\" & strOutputFileName
        If Not .Show() Then Exit Sub 'exit if user selected Cancel
    End With
    
'finish up
'    Set fso = Nothing
    If Not bQuestionnaireAlreadyOpen Then wbkInput.Close savechanges:=False
    If Not bLeaveOpen Then
        docOutput.Close savechanges:=False
        Set docOutput = Nothing
        wdApp.Quit
        Set wdApp = Nothing
    End If
    Application.StatusBar = False
    Application.ScreenUpdating = True
    
    MsgBox "Finished", vbInformation, "MVP"
    Exit Sub
    
End Sub


Private Function IsWorkbookAlreadyOpen(ByVal WorkbookName As String) As Boolean
    
    Dim wbk As Workbook
    
    IsWorkbookAlreadyOpen = False
    For Each wbk In Application.Workbooks
        If wbk.Name = WorkbookName Then
            IsWorkbookAlreadyOpen = True
            Exit Function
        End If
    Next wbk
    Exit Function
    
End Function



Sub CreateWordDoc()

    Dim wdApp As Word.Application
    Dim strOutputFile As String
    Dim docOutput As Document
    Dim intListRow As Integer
    Dim shtList As Worksheet
    Dim intTableCount As Integer, intTableCounter As Integer
    Dim wbkSource As Workbook, shtSource As Worksheet
    Dim intStartRow As Integer, intEndRow As Integer, intEndCol As Integer, intCol As Integer
    Dim bkm As Word.Bookmark
    Dim bAlreadyOpen As Boolean
    Dim strStartFolder As String, strWordTemplate As String
    Dim intTblRow As Integer, bShadeRow As Boolean
    Dim fso As New FileSystemObject, dtMod As Date, bDateCheckFail As Boolean, bIgnoreDateCheck As Integer
    Dim intDelay As Integer
    Dim tsLog As TextStream
    
    bDateCheckFail = False
    bIgnoreDateCheck = False
    Set shtList = ThisWorkbook.Worksheets("List")
    
'count tables to process and check file mod dates
    intListRow = 2
    Application.StatusBar = "Counting tables to process and checking file dates"
    Do Until shtList.Cells(intListRow, 1).Value = ""
        If shtList.Cells(intListRow, 10).Value Then
            intTableCount = intTableCount + 1
            dtMod = fso.GetFile(shtList.Cells(intListRow, 1).Value).DateLastModified
            If dtMod <> shtList.Cells(intListRow, 9).Value Then
                bDateCheckFail = True
                shtList.Cells(intListRow, 11).Value = "Source file dates don't match"
            End If
        End If
        intListRow = intListRow + 1
    Loop
    
'exit if no tables selected
    If intTableCount = 0 Then
        MsgBox "No tables selected for processing", vbCritical, strHeader
        Exit Sub
    End If
    
'check with user if mod date check fails
    If bDateCheckFail Then
        If MsgBox("One or more file modified dates do not match values stored here. Tables could have moved within these files. " & _
            "You are advised to stop and rebuild the list." & vbCr & vbCr & "Do you wish to continue? (no further warnings will be generated)", _
            vbYesNo + vbExclamation, strHeader) = vbYes Then
            bIgnoreDateCheck = True
        Else
            Set fso = Nothing
            Application.ScreenUpdating = True
            Application.StatusBar = False
            Exit Sub
        End If
    End If
    
'start MS Word
    Application.ScreenUpdating = False
    Application.StatusBar = "Opening Word and template ..."
    strStartFolder = ThisWorkbook.Path
    strWordTemplate = ThisWorkbook.Worksheets("Home").Range("Word_Template").Value 'word template
    If Dir(strWordTemplate) = "" Then
        MsgBox "Word template not found", vbCritical, strHeader
        Exit Sub
    End If
    
    'Set docOutput = wdApp.Documents.Add(strWordTemplate)
    On Error GoTo errLaunchWord
        Set wdApp = New Word.Application
        DoEvents
        wdApp.Visible = True
        wdApp.Activate
    On Error GoTo 0
    wdApp.DisplayAlerts = wdAlertsNone
    Set docOutput = wdApp.Documents.Open(Filename:=strWordTemplate, ReadOnly:=True)
    wdApp.ActiveWindow.View.Type = wdNormalView
    DoEvents
    strOutputFile = strStartFolder & "\Output\fee_survey_" & Format(Now, "YYYYMMDDhhnnss") & ".docx"
    docOutput.SaveAs2 Filename:=strOutputFile
    Application.StatusBar = False
    Set tsLog = fso.OpenTextFile(strStartFolder & "\Excel_To_Word.log", ForWriting, True)
    tsLog.WriteLine "Process started: " & Format(Now(), "YYYY-MM-DD hh:mm:ss")
    DoEvents
    
'process tables
    intListRow = 2
    For intListRow = shtList.Cells(intListRow, 1).End(xlDown).Row To 2 Step -1
        DoEvents
        If shtList.Cells(intListRow, 10).Value Then
            intTableCounter = intTableCounter + 1
            Application.StatusBar = "Processing table " & intTableCounter & " of " & intTableCount
            If Not IsFileAlreadyOpen(shtList.Cells(intListRow, 1).Value, wbkSource) Then
                If Not wbkSource Is Nothing Then wbkSource.Close savechanges:=False
                Set wbkSource = Workbooks.Open(Filename:=shtList.Cells(intListRow, 1).Value, UpdateLinks:=False, ReadOnly:=True)
                bAlreadyOpen = False
            Else
                bAlreadyOpen = True
            End If
            Set shtSource = wbkSource.Worksheets(shtList.Cells(intListRow, 2).Value)
            
        'read table location and dimensions
            intStartRow = shtList.Cells(intListRow, 6).Value
            intEndRow = shtList.Cells(intListRow, 7).Value
            intEndCol = shtList.Cells(intListRow, 8).Value
            
        'format table in Excel
            bShadeRow = False
            With shtSource.Range(shtSource.Cells(intStartRow + 1, 1), shtSource.Cells(intStartRow + 1, intEndCol))
                .Font.FontStyle = "Arial"
                .Font.Bold = True
                .Font.Size = 11
                .Font.Color = vbWhite
                .Interior.Color = RGB(0, 44, 119)
                .Borders(xlEdgeTop).LineStyle = xlNone
                .Borders(xlEdgeBottom).LineStyle = xlNone
                .Borders(xlEdgeLeft).LineStyle = xlNone
                .Borders(xlEdgeRight).LineStyle = xlNone
                .Borders(xlInsideHorizontal).LineStyle = xlNone
                With .Borders(xlInsideVertical)
                    .LineStyle = xlContinuous
                    .ThemeColor = 1
                    .TintAndShade = 0
                    .Weight = xlThin
                End With
            End With
            For intTblRow = intStartRow + 2 To intEndRow
                With shtSource.Range(shtSource.Cells(intTblRow, 1), shtSource.Cells(intTblRow, intEndCol))
                    .Font.FontStyle = "Arial"
                    .Font.Bold = False
                    .Font.Size = 11
                    .Font.Color = RGB(0, 44, 119)
                    .Borders(xlEdgeLeft).LineStyle = xlNone
                    .Borders(xlEdgeTop).LineStyle = xlNone
                    .Borders(xlEdgeBottom).LineStyle = xlNone
                    .Borders(xlEdgeRight).LineStyle = xlNone
                    .Borders(xlInsideVertical).LineStyle = xlNone
                    .Borders(xlInsideVertical).LineStyle = xlNone
                    If Not bShadeRow Then
                        .Interior.Color = vbWhite
                    Else
                        '.Interior.Color = RGB(221, 221, 221)
                        .Interior.TintAndShade = -4.99893185216834E-02
                    End If
                    bShadeRow = Not bShadeRow 'alternate row shading
                End With
            Next intTblRow
            shtSource.Range(shtSource.Cells(intStartRow + 1, 2), shtSource.Cells(intEndRow, intEndCol)).HorizontalAlignment = xlCenter
            
        'copy table
            docOutput.Bookmarks("bmkFeeSchedules").Select
            wdApp.Selection.TypeParagraph
            shtSource.Range(shtSource.Cells(intStartRow + 1, 1), shtSource.Cells(intEndRow, intEndCol)).Copy
            DoEvents
            wdApp.Selection.PasteSpecial DataType:=Word.WdPasteDataType.wdPasteRTF
            wdApp.Selection.MoveUp Unit:=wdLine, Count:=1
            wdApp.Selection.Tables(1).AutoFitBehavior (wdAutoFitContent)
            For intCol = 2 To wdApp.Selection.Tables(1).Columns.Count
                wdApp.Selection.Tables(1).Columns(intCol).Width = CentimetersToPoints(2.4)
            Next intCol
        'copy title
            intErrorCount = 0
            'shtSource.Cells(intStartRow, 1).Copy
            docOutput.Bookmarks("bmkFeeSchedules").Range.Text = shtSource.Cells(intStartRow, 1).Value
            docOutput.Bookmarks("bmkFeeSchedules").Select
            wdApp.Selection.TypeParagraph
            tsLog.WriteLine wbkSource.Path & vbTab & wbkSource.Name & vbTab & shtSource.Cells(intStartRow, 1).Value
            
'wdApp.Selection.PasteSpecial DataType:=Word.WdPasteDataType.wdPasteText
            DoEvents
            shtList.Cells(intListRow, 12).Value = strOutputFile
        End If
        docOutput.Save
    Next intListRow
    'docOutput.Save
    docOutput.Close savechanges:=False
    tsLog.WriteLine "Process finished: " & Format(Now(), "YYYY-MM-DD hh:mm:ss")
    tsLog.Close
'finish up
    Set docOutput = Nothing
    Set wdApp = Nothing
    Set fso = Nothing
'close workbooks
    intListRow = 2
    Application.StatusBar = "Closing source workbooks"
    Do Until shtList.Cells(intListRow, 1).Value = ""
        If shtList.Cells(intListRow, 10).Value Then
            If IsFileAlreadyOpen(shtList.Cells(intListRow, 1).Value, wbkSource) Then wbkSource.Close savechanges:=False
        End If
        intListRow = intListRow + 1
    Loop
    Application.StatusBar = False
    Application.ScreenUpdating = True
    MsgBox "Finished" & vbCr & vbCr & intTableCounter & " tables copied over", vbInformation, strHeader
    Exit Sub

errLaunchWord:
    If MsgBox("Please launch Word and click 'OK'", vbOKCancel + vbExclamation, strHeader) = vbCancel Then Exit Sub
    Resume

errDelay:
    intErrorCount = intErrorCount + 1
    If intErrorCount > intMaxErrorCount Then
        MsgBox "Giving up: I've tried pausing before pasting but Word still won't paste", vbCritical, strHeader
        Exit Sub
    End If
    DoEvents
    intDelay = 2 * intErrorCount
    Application.Wait (Now + TimeValue("0:00:" & Format(intDelay, "00")))
    Resume

End Sub