I am taking the running of the code from someone from work, I am attempting to move specific cells within a excel spreadsheet to a Microsoft word document. Currently, three paragraphs are moved over, however, I want to introduce a 4th paragraph, with the *** representing code I have added in.
When I try running the code after adding the lines in, I get the error message "The requested member of the collection does not exist". Can anyone look over the code and see where I am going wrong?
Apologies, I have added the entire code block, so it is lengthy. Thanks
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
CodePudding user response:
The bookmark "Paragraph 4" has to already exist in the template file that the output document is being created from..