Excel VBA - Insert combo boxes into MS Word - excel

I have a an Excel workbook with that creates a table and exports the table to MS word. My client now wants to also insert a drop down list into the last column of the word table. I cannot find any material on this. Can it be done? I would like to create a combobox and insert it into each cell in the "Interpretation" column. Can someone point me in the right direction or supply some sample code?
Current code:
Sub ExportToWord()
Dim ws As Worksheet
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Dim objRange As Word.Range
Dim bWeStartedWord As Boolean
Dim newDoc As Boolean, onSave As Boolean
Dim rng As Range
Dim lRow As Integer, s As Integer
If UF_Load.check_new = True Then
newDoc = True
Else
newDoc = False
End If
Set ws = ThisWorkbook.Sheets("UI")
On Error Resume Next
Set wrdApp = GetObject(, "Word.Application")
On Error GoTo 0
Application.ScreenUpdating = False
Application.EnableEvents = False
s = ws.Range("rng_demo").Row - 1
c = ws.Range("rng_demo").Column
lRow = ws.Cells(Rows.count, s).End(xlUp).Row
Set rng = ws.Range("A" & s).Resize(lRow, 8)
rng.Copy
If wrdApp Is Nothing Then
Set wrdApp = CreateObject("Word.Application")
bWeStartedWord = True
End If
'Handle if Word Application is not found
If Err.Number = 429 Then
MsgBox "Microsoft Word document could not be found, aborting", vbExclamtion, "Microsoft Word Error 429"
GoTo SafeExit:
End If
On Error GoTo 0
'Make MS Word Visible and Active
wrdApp.Visible = True
wrdApp.Activate
'
wrdApp.Visible = True
If newDoc = True Then
Set wrdDoc = wrdApp.Documents.Add 'create as new word document
'Copy table data to word doc
Set tbl = rng 'ThisWorkbook.Sheets("UI").Range("A4:H25")
tbl.Copy
'Paste Table into Word doc
wrdDoc.Paragraphs(1).Range.PasteExcelTable _
LinkedToExcel:=False, _
WordFormatting:=False, _
RTF:=False
'Autofit table to Word doc
Set wordtable = wrdDoc.Tables(1)
wordtable.AutoFitBehavior (wdAutoFitWindow)
Else
'or open an existing document
Set wrdDoc = wrdApp.Documents.Open(filepath) 'wrdApp.Documents.Open("C:\Users\Apache Paint\Desktop\Clients\Stephen Schmitz\TestDocument.docx")
'Copy table data to word doc
With wrdDoc
Set tbl1 = .Tables.Add(Range:=wrdDoc.Paragraphs.Last.Range, _
NumRows:=1, NumColumns:=8, _
AutoFitBehavior:=wdAutoFitWindow) 'autofit content 'DefaultTableBehavior:=wdWord9TableBehavior,
With tbl1
.PreferredWidthType = wdPreferredWidthPercent
.PreferredWidth = 100
End With
Set tbl = rng 'ThisWorkbook.Sheets("UI").Range("A4:H25")
tbl.Copy
Set objRange = wrdDoc.Content
With objRange
.Collapse Direction:=0 'wdCollapseEnd
.InsertAfter vbCrLf
.Collapse Direction:=0
.InsertBreak Type:=wdPageBreak
.Paste '<< paste the table
End With
'Autofit the document
Set wordtable = objRange.Tables(1)
wordtable.AutoFitBehavior (wdAutoFitWindow)
With wordtable
.PreferredWidthType = wdPreferredWidthPercent
.PreferredWidth = 100
End With
End With
filepath = ""
End If
SafeExit:
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.CutCopyMode = False
End Sub

I was able to get it to work with the code below. Thanks to those who suggested I look into ContentControl.
Now I am intermittently getting 'Run-time error 462. The remote server machine does not exist or is unavailable.'
I will update the cooment back here when it is fully resolved.
'Copy table data to word doc
Set tbl = rng 'ThisWorkbook.Sheets("UI").Range("A4:H25")
tbl.Copy
'Paste Table into Word doc
wrdDoc.Paragraphs(1).Range.PasteExcelTable _
LinkedToExcel:=False, _
WordFormatting:=False, _
RTF:=False
'Autofit table to Word doc
Set Wordtable = wrdDoc.Tables(1)
Wordtable.AutoFitBehavior (wdAutoFitWindow)
Dim oRow As Row
'Dim oRng As Range
'Loop through last table column and add Combobox
With Wordtable
For Each oRow In Wordtable.Rows
'Set oRng = oRow.Cells(1).Range
If Len(oRow.Cells(7).Range.Text) > 11 Then
Set objCC = ActiveDocument.ContentControls.Add(wdContentControlDropdownList, oRow.Cells(8).Range)
objCC.Title = "Interpretation"
If objCC.ShowingPlaceholderText Then
objCC.SetPlaceholderText , , "-Select-"
objCC.DropdownListEntries.Add "Far Below Expectaions"
objCC.DropdownListEntries.Add "Below Expectaions"
objCC.DropdownListEntries.Add "Slightly Below Expectaions"
objCC.DropdownListEntries.Add "Significant Difference"
objCC.DropdownListEntries.Add "Valid"
objCC.DropdownListEntries.Add "WNL"
Debug.Print Len(oRow.Cells(7).Range.Text)
End If
Else
End If
Next
End With

Related

Trying to create a VBA to paste an Excel table into Word

I've created a macro to paste an Excel table into word but the macro isn't working, and I can't figure out what I'm doing wrong. See code below for reference.
I've also checked the "Reference" --> "Microsoft Word 16.0 Object Library"
TIA!
'
' CreateLabels Macro
Dim objWord
Dim objDoc
Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.Documents.Open("C:\Users\username\Desktop\New Template.doc")
Dim x As Workbook
'Open Excel and Copy labels
Set x = Workbooks.Open("Excel file path")
With x.Sheets("Receiving Labels")
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
End With
x.Sheets("Receiving Labels").Range("A1:E" & LastRow).Copy
With objDoc.Paragraphs(objDoc.Paragraphs.Count).Range
'All formatting goes here
.Paste
.Font.Name = "Calibri"
.Font.Color = wdColorBlack
.Font.Bold = False
.Font.Italic = False
.Font.Allcaps = False
.Font.Size = 8
End With
objWord.Visible = True
End Sub
Try this:
Sub ExcelToWord()
'PURPOSE: Copy/Paste An Excel Table Into a New Word Document
'NOTE: Must have Word Object Library Active in Order to Run _
(VBE > Tools > References > Microsoft Word 12.0 Object Library)
'SOURCE: www.TheSpreadsheetGuru.com
Dim tbl As Excel.Range
Dim WordApp As Word.Application
Dim myDoc As Word.Document
Dim WordTable As Word.Table
'Optimize Code
Application.ScreenUpdating = False
Application.EnableEvents = False
'Copy Range from Excel
Set tbl = ThisWorkbook.Worksheets(Sheet1.Name).ListObjects("Table1").Range
'Create an Instance of MS Word
On Error Resume Next
'Is MS Word already opened?
Set WordApp = GetObject(class:="Word.Application")
'Clear the error between errors
Err.Clear
'If MS Word is not already open then open MS Word
If WordApp Is Nothing Then Set WordApp = CreateObject(class:="Word.Application")
'Handle if the Word Application is not found
If Err.Number = 429 Then
MsgBox "Microsoft Word could not be found, aborting."
GoTo EndRoutine
End If
On Error GoTo 0
'Make MS Word Visible and Active
WordApp.Visible = True
WordApp.Activate
'Create a New Document
Set myDoc = WordApp.Documents.Add
'Copy Excel Table Range
tbl.Copy
'Paste Table into MS Word
myDoc.Paragraphs(1).Range.PasteExcelTable _
LinkedToExcel:=False, _
WordFormatting:=False, _
RTF:=False
'Autofit Table so it fits inside Word Document
Set WordTable = myDoc.Tables(1)
WordTable.AutoFitBehavior (wdAutoFitWindow)
EndRoutine:
'Optimize Code
Application.ScreenUpdating = True
Application.EnableEvents = True
'Clear The Clipboard
Application.CutCopyMode = False
End Sub

VBA Excel to Word Content Control Running Slowly

I have a simple interface in Excel that allows the user to export a table from Excel to Word as a new or existing document. It then loops through the last column(8) in the word table and inserts a drop down list in each cell.
The code does what it is supposed to do but runs slowly when inserting the content controls. Additionally, I can see it insert each content control in MS Word which tells me that screen updating is not disabled in Word. Any suggestions to make my code to run faster?
Full code and reference word table below.
Sub ExportToWord()
Dim ws As Excel.Worksheet
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Dim objRange As Word.Range
Dim newDoc As Boolean
Dim rng As Excel.Range
Dim lRow As Integer, s As Integer
Dim objCC As ContentControl
Dim counter As Long
Dim oRow As Row
If UF_Load.check_new = True Then
newDoc = True
Else
newDoc = False
End If
Set ws = ThisWorkbook.Sheets("UI")
Application.ScreenUpdating = False
Application.EnableEvents = False
s = ws.Range("rng_demo").Row - 2
c = ws.Range("rng_demo").Column
lRow = ws.Cells(Rows.Count, s).End(xlUp).Row
Set rng = ws.Range("A" & s).Resize(lRow, 8)
rng.Copy
If wrdApp Is Nothing Then
On Error Resume Next
Set wrdApp = GetObject(, "Word.Application")
If Err.Number > 0 Then Set wrdApp = CreateObject("Word.Application")
On Error GoTo 0
End If
'Handle if Word Application is not found
If Err.Number <> 0 Then GoTo SafeExit:
'MsgBox "Microsoft Word document could not be found, aborting", vbExclamtion, "Microsoft Word Error 429"
'GoTo SafeExit:
'End If
On Error GoTo 0
'Make MS Word Visible and Active
wrdApp.Activate
wrdApp.Visible = True
If newDoc = True Then
Set wrdDoc = wrdApp.Documents.Add 'create as new word document
'Set as editable
If wrdDoc.ActiveWindow.View.SplitSpecial = wdPaneNone Then
wrdDoc.ActiveWindow.ActivePane.View.Type = wdPrintView
Else
wrdDoc.ActiveWindow.View.Type = wdPrintView
End If
'Copy table data to word doc
Set tbl = rng
tbl.Copy
'Paste Table into Word doc
wrdDoc.Paragraphs(1).Range.PasteExcelTable _
LinkedToExcel:=False, _
WordFormatting:=False, _
RTF:=False
'Autofit table to Word doc
Set Wordtable = wrdDoc.Tables(1)
Wordtable.AutoFitBehavior (wdAutoFitWindow)
'Dim oRng As Range
'Loop through last table column and add Combobox
'Insert comboboxes
With Wordtable
counter = 0
For Each oRow In Wordtable.Rows
'Set oRng = oRow.Cells(1).Range
'If Trim(Len(oRow.Cells(1).Range.Text)) <> " " Then
If Len(Trim(Replace(oRow.Cells(1).Range.Text, Chr(160), ""))) <> 2 And counter >= 8 Then 'GoTo Nexti:
On Error Resume Next
Set objCC = wrdApp.ActiveDocument.ContentControls.Add(wdContentControlDropdownList, oRow.Cells(8).Range)
If Err.Number = 5941 Then GoTo Nexti:
objCC.Title = "Interpretation"
If objCC.ShowingPlaceholderText Then
objCC.SetPlaceholderText , , "-"
objCC.DropdownListEntries.Add "Valid"
objCC.DropdownListEntries.Add "Significant Difference"
objCC.DropdownListEntries.Add "WNL"
objCC.DropdownListEntries.Add "Slightly Below Expectations"
objCC.DropdownListEntries.Add "Below Expectations"
objCC.DropdownListEntries.Add "Far Below Expectations"
Debug.Print Len(oRow.Cells(7).Range.Text)
End If
Else
'Do nothing
End If
Nexti:
On Error GoTo 0
counter = counter + 1
Next
End With
On Error GoTo SafeExit:
Else
'or open an existing document
Set wrdDoc = wrdApp.Documents.Open(filepath, , False) 'wrdApp.Documents.Open("C:\Users\Apache Paint\Desktop\Clients\Stephen Schmitz\TestDocument.docx")
'Set as editable
If wrdDoc.ActiveWindow.View.SplitSpecial = wdPaneNone Then
wrdDoc.ActiveWindow.ActivePane.View.Type = wdPrintView
Else
wrdDoc.ActiveWindow.View.Type = wdPrintView
End If
'Copy table data to word doc
With wrdDoc
Set tbl1 = .Tables.Add(Range:=wrdDoc.Paragraphs.Last.Range, _
NumRows:=1, NumColumns:=8, _
AutoFitBehavior:=wdAutoFitWindow) 'autofit content 'DefaultTableBehavior:=wdWord9TableBehavior,
With tbl1
.PreferredWidthType = wdPreferredWidthPercent
.PreferredWidth = 100
End With
Set tbl = rng
Set objRange = wrdDoc.Content
With objRange
.Collapse Direction:=0 'wdCollapseEnd
'.InsertAfter vbCrLf '<<< Error on line
.Collapse Direction:=0
.InsertBreak Type:=wdPageBreak
.Paste '<< paste the table
End With
'Autofit the document
Set Wordtable = objRange.Tables(1) 'Set Wordtable = objRange.Tables(1)
Wordtable.AutoFitBehavior (wdAutoFitWindow)
With Wordtable
.PreferredWidthType = wdPreferredWidthPercent
.PreferredWidth = 100
'Insert comboboxes
counter = 0
For Each oRow In Wordtable.Rows
Set oRng = oRow.Cells(1).Range
If Len(Trim(Replace(oRow.Cells(1).Range.Text, Chr(160), ""))) <> 2 And counter >= 8 Then 'GoTo Nexti:
On Error Resume Next
Set objCC = wrdApp.ActiveDocument.ContentControls.Add(wdContentControlDropdownList, oRow.Cells(8).Range)
If Err.Number = 5941 Then GoTo Nexti2:
objCC.Title = "Interpretation"
If objCC.ShowingPlaceholderText Then
objCC.SetPlaceholderText , , "-"
objCC.DropdownListEntries.Add "Valid"
objCC.DropdownListEntries.Add "Significant Difference"
objCC.DropdownListEntries.Add "WNL"
objCC.DropdownListEntries.Add "Slightly Below Expectations"
objCC.DropdownListEntries.Add "Below Expectations"
objCC.DropdownListEntries.Add "Far Below Expectations"
Debug.Print Len(oRow.Cells(7).Range.Text)
End If
Else
'Do nothing
End If
Nexti2:
On Error GoTo 0
counter = counter + 1
Next
End With
End With
filepath = ""
End If
SafeExit:
If Err.Number <> 0 Then
Beep
MsgBox "Microsoft Excel has encountered an error and could not complete the Export to MS Word. Possible reasons are:" & vbNewLine & vbNewLine & _
"-Reference to Microsoft Word Object Library is not enabled" & vbNewLine & vbNewLine & "-The document opened in Read Only mode" & vbNewLine & vbNewLine & _
"-Code execution was interrupted because the was closed or altered during execution" & vbNewLine & vbNewLine & "-Document is already open in MS Word" _
, vbCritical, "Error"
End If
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.CutCopyMode = False
End Sub
It seems to me your code could be made both more efficient and shorter:
Sub ExportToWord()
Application.ScreenUpdating = False: Application.EnableEvents = False
Dim ws As Excel.Worksheet, rng As Excel.Range, lRow As Long, c As Long, r As Long, newDoc As Boolean
Dim wrdApp As Word.Application, wrdDoc As Word.Document, wrdTbl As Word.Table, wrdCCtrl As Word.ContentControl
Const filepath As String = "C:\Users\Apache Paint\Desktop\Clients\Stephen Schmitz\TestDocument.docx"
Set ws = ThisWorkbook.Sheets("UI")
With ws
c = .Range("rng_demo").Column
r = .Range("rng_demo").Row - 2
lRow = .Cells(.Rows.Count, c).End(xlUp).Row
Set rng = .Range("A" & r).Resize(lRow, 8)
End With
If wrdApp Is Nothing Then
On Error Resume Next
Set wrdApp = GetObject(, "Word.Application")
If Err.Number > 0 Then Set wrdApp = CreateObject("Word.Application")
On Error GoTo 0
End If
With wrdApp
.Visible = True
If UF_Load.check_new = True = True Then
'create as new word document
Set wrdDoc = wrdApp.Documents.Add
'create a table
Set wrdTbl = wrdDoc.Tables.Add(Range:=wrdDoc.Paragraphs.Last.Range, NumRows:=1, NumColumns:=8)
Else
'open an existing document
Set wrdDoc = .Open(filepath, , False)
'copy & paste the Excel table
rng.Copy
Set wrdTbl = wrdDoc.Paragraphs.Last.Range.PasteExcelTable(LinkedToExcel:=False, WordFormatting:=False, RTF:=False)
End If
With wrdDoc
With wrdTbl
'format the table
.PreferredWidthType = wdPreferredWidthPercent
.PreferredWidth = 100
'Insert comboboxes
For r = 9 To .Rows.Count
If r = 9 Then
Set wrdCCtrl = wrdDoc.ContentControls.Add(wdContentControlDropdownList, .Cell(r, 8).Range)
With wrdCCtrl
.Title = "Interpretation"
.SetPlaceholderText , , "-"
.DropdownListEntries.Add "Valid"
.DropdownListEntries.Add "Significant Difference"
.DropdownListEntries.Add "WNL"
.DropdownListEntries.Add "Slightly Below Expectations"
.DropdownListEntries.Add "Below Expectations"
.DropdownListEntries.Add "Far Below Expectations"
End With
Else
.Cell(r, 8).Range.FormattedText = wrdCCtrl.Range.FormattedText
End If
Next
End With
End With
End With
Application.ScreenUpdating = True: Application.EnableEvents = True: Application.CutCopyMode = False
End Sub

Excel copy to Word VBA

I have some code that I am working on with the macro recorder. In word it always begins with Selection. This article https://exceloffthegrid.com/controlling-word-from-excel-using-vba/?unapproved=9388&moderation-hash=83a9b85f06d7f960463f59103685510b#comment-9388 says I should be able to assign the document to a variable and just insert this before .Selection. However the selection method doesn't appear in VBE for me after I type my document variable. I get a run time error 438 'object doesn't support this property or method' on my first use of the word Selection object (Selection.EndKey). As far as I can see the GoTo method should select the start of the heading.
Sub ExcelToWord()
'
' Select data in excel and copy to GIR
'
'
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim wb As Workbook
Dim ws As Worksheet
Dim wdApp As Word.Application
Dim GIR As Word.Document
Dim GIRName As String
Dim GEOL As String
Dim Tbl As Long
Set wdApp = New Word.Application '<<< Create a Word application object
wdApp.Visible = True '<<<< Open word so you can see any errors
GIRName = Application.GetOpenFilename(Title:="Please choose GIR to open", _
FileFilter:="Word Files *.docm* (*.docm*),")
Set GIR = wdApp.Documents.Open(GIRName) '<< call Documents.Open on the word app
'Loop through excel workbook to copy data
Set wb = ThisWorkbook
Set ws = ActiveSheet
For Each ws In wb.Worksheets
If UCase(ws.Name) <> "TEMPLATE" And ws.Visible = True Then
ws.Name = Replace(ws.Name, "(Blank)", "NoGEOLCode")
ws.Activate
GEOL = Range("C9").Value
Tbl = 1
Range("A14").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
'Paste each worksheet's data into word as new heading
GIR.Activate
GIR.Content.GoTo What:=wdGoToHeading, Which:=wdGoToFirst, Count:=5, Name:=""
Selection.EndKey Unit:=wdLine
Selection.TypeParagraph
Selection.Style = ActiveDocument.Styles("Heading 2")
Selection.TypeText Text:=GEOL
Selection.TypeParagraph
Selection.Tables.Add Range:=Selection.Range, NumRows:=53, NumColumns:=7, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:=wdAutoFitWindow
With Selection.Tables(Tbl)
If .Style <> "Table1" Then
.Style = "Table1"
End If
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = False
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = False
.ApplyStyleRowBands = True
.ApplyStyleColumnBands = False
End With
Selection.PasteAndFormat (wdFormatPlainText)
Tbl = Tbl + 1
Selection.GoTo What:=wdGoToSection, Which:=wdGoToFirst, Count:=6, Name:=""
Selection.MoveUp Unit:=wdLine, Count:=1
Selection.TypeParagraph
End If
Next
GIR.Save
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
There are several issues with your code.
It is bad practice to use the Selection object for various reasons. It is better to use Range instead, both in Excel and Word.
You set the variable GIR to the document you opened but then use ActiveDocument instead.
You add your table into a paragraph formatted with Heading 2 style. For table styles to work correctly the underlying paragraph style must be Normal. This is because there is a hierarchy of styles in Word with table styles at the bottom, just above document default which is represented by Normal.
You set the variable NewTbl to point to the table you created but make no further use of it.
The line With wdApp.Selection.Tables(Tbl) will error as there will only be one table in the Selection.
I have rewritten your code as below. I have left the final 3 lines of Word code unaltered as I am unsure exactly what you are doing there, a consequence of attempting to debug code without the document being worked on. I have tested this code using some dummy data and it works for me in O365.
Sub ExcelToWord()
'
' Select data in excel and copy to GIR
'
'
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim wb As Workbook
Dim ws As Worksheet
Dim wdApp As Word.Application
Dim GIR As Word.Document
Dim GIRName As String
Dim GEOL As String
Dim Tbl As Long
Dim NewTbl As Word.Table
Dim wdRange As Word.Range
Set wdApp = New Word.Application '<<< Create a Word application object
wdApp.Visible = True '<<<< Open word so you can see any errors
GIRName = Application.GetOpenFilename(Title:="Please choose GIR to open", _
FileFilter:="Word Files *.docm* (*.docm*),")
Set GIR = wdApp.Documents.Open(GIRName) '<< call Documents.Open on the word app
'Loop through excel workbook to copy data
Set wb = ThisWorkbook
Set ws = ActiveSheet
For Each ws In wb.Worksheets
If UCase(ws.Name) <> "TEMPLATE" And ws.Visible = True Then
ws.Name = Replace(ws.Name, "(Blank)", "NoGEOLCode")
ws.Activate
GEOL = Range("C9").Value
Tbl = 1
Range("A14").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
'Paste each worksheet's data into word as new heading
Set wdRange = wdApp.Selection.GoTo(What:=wdGoToHeading, _
Which:=wdGoToFirst, Count:=4, Name:="")
With wdRange
' wdApp.Selection.EndKey Unit:=wdLine
' wdApp.Selection.TypeParagraph
.End = .Paragraphs(1).Range.End
.InsertParagraphAfter
.MoveStart wdParagraph
.MoveEnd wdCharacter, -1
' wdApp.Selection.Style = ActiveDocument.Styles("Heading 2")
.Style = GIR.Styles(wdStyleHeading2)
' wdApp.Selection.TypeText Text:=GEOL
.Text = GEOL
' wdApp.Selection.TypeParagraph
.InsertParagraphAfter
.Collapse wdCollapseEnd
.Style = GIR.Styles(wdStyleNormal)
Set NewTbl = GIR.Tables.Add(Range:=wdRange, NumRows:=53, _
NumColumns:=7, DefaultTableBehavior:=wdWord9TableBehavior, _
AutoFitBehavior:=wdAutoFitWindow)
' With wdApp.Selection.Tables(Tbl)
With NewTbl
If .Style <> "Table1" Then
.Style = "Table1"
End If
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = False
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = False
.ApplyStyleRowBands = True
.ApplyStyleColumnBands = False
.Range.PasteAndFormat wdFormatPlainText
End With
' wdApp.Selection.PasteAndFormat (wdFormatPlainText)
' Tbl = Tbl + 1
wdApp.Selection.GoTo What:=wdGoToSection, Which:=wdGoToFirst, _
Count:=6, Name:=""
wdApp.Selection.MoveUp Unit:=wdLine, Count:=1
wdApp.Selection.TypeParagraph
End With
End If
Next
GIR.Save
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

Word document doesn't close properly

Data dynamically populating from drop-down list correctly; however, how may I get the Word document to close properly in between each entry?
Problem:
The Word document doesn't close properly in between each new entry in the Excel dynamic drop-down list.
What is occurring:
The loop is executing over each hospital; however, Word isn't closing in between each new entity. Result is that all the addresses and tables are inserting without interruption.
What should occur:
Each hospital with it's own unique data in a new Word document (attached, the Excel sheet "Table" has a drop-down in call B2 that autopopulates the table 1 and the hospital's address; the Word document has bookmarks to insert this data).
In advance, thank you very much for your expertise. I have tried various commands to close the active document in Word (not shown) but then cannot get Word to open up again with the template. Realize there is likely a simple solution to incorporate into the existing code.
Regards,
Karen
Sub MMISPMT()
Worksheets("table").Activate
'Declare variables
Dim WordApp As Object
Dim WordDoc As Object
Dim dvCell As Range
Dim inputRange As Range
Dim c As Range
ActiveWindow.View = xlNormalView
'Set variables
'Which cell has data validation
Set dvCell = Worksheets("Table").Range("B2") 'this is a drop-down box of entity name values that
populates address info and table 1 in Word document
'Determine where validation comes from
Set inputRange = Evaluate(dvCell.Validation.Formula1)
Set WordApp = New Word.Application ' based on the template ref'd in WordDoc
'Word template to be used
Set WordDoc = WordApp.Documents.Add(Template:="C:\<pathway>\letter.docx", NewTemplate:=False,
DocumentType:=0)
'Begin loop
Application.ScreenUpdating = False
For Each c In inputRange
dvCell = c.Value
MsgBox dvCell
Debug.Print dvCell
Dim table1 As Range
Dim HosName As Range
Dim address1 As Range
Dim city As Range
Dim zip As Range
'Declare variables
Set table1 = Range("a10:g15")
Set HosName = Range("b2")
Set address1 = Range("ad5")
Set city = Range("ad6")
Set zip = Range("ad7")
HosName.Select
Selection.Copy
WordApp.Visible = True
WordApp.ActiveDocument.Bookmarks("HosName").Select
Set objSelection = WordApp.Selection
objSelection.PasteSpecial DataType:=wdPasteText
address1.Select
Selection.Copy
WordApp.Visible = True
WordApp.ActiveDocument.Bookmarks("address1").Select
Set objSelection = WordApp.Selection
objSelection.PasteSpecial DataType:=wdPasteText
city.Select
Selection.Copy
WordApp.Visible = True
WordApp.ActiveDocument.Bookmarks("city").Select
Set objSelection = WordApp.Selection
objSelection.PasteSpecial DataType:=wdPasteText
zip.Select
Selection.Copy
WordApp.Visible = True
WordApp.ActiveDocument.Bookmarks("zip").Select
Set objSelection = WordApp.Selection
objSelection.PasteSpecial DataType:=wdPasteText
table1.Select
Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
WordApp.Visible = True
WordApp.ActiveDocument.Bookmarks("table1").Select
Set objSelection = WordApp.Selection
objSelection.Paste
'Generate the Word template per hospital with data
WordApp.ActiveDocument.SaveAs2 Filename:="C:\<pathway>\" & HosName & " " & Format((Year(Now() + 1)
Mod 100), "20##") & _
Format((Month(Now() + 1) Mod 100), "0#") & _
Format((Day(Now()) Mod 100), "0#") & "-report.docx", _
FileFormat:=wdFormatXMLDocument
Next c
Application.ScreenUpdating = True
End Sub
You need to open the template at the top of the loop, then save and close the document at the bottom of the loop.
Also you can tidy up your code by factoring the copy/paste into a separate method.
Sub MMISPMT()
Dim WordApp As Object
Dim WordDoc As Object
Dim dvCell As Range
Dim inputRange As Range
Dim c As Range, wsTable As Worksheet
Set wsTable = Worksheets("Table")
Set dvCell = Worksheets("Table").Range("B2")
Set inputRange = Evaluate(dvCell.Validation.Formula1)
Set WordApp = New Word.Application ' based on the template ref'd in WordDoc
For Each c In inputRange.Cells
Set WordDoc = WordApp.Documents.Add(Template:="C:\<pathway>\letter.docx", _
NewTemplate:=False, DocumentType:=0)
dvCell = c.Value
CopyToBookmark wsTable.Range("B2"), WordDoc, "HosName"
CopyToBookmark wsTable.Range("AD5"), WordDoc, "address1"
CopyToBookmark wsTable.Range("AD6"), WordDoc, "city"
CopyToBookmark wsTable.Range("AD7"), WordDoc, "zip"
CopyToBookmark wsTable.Range("A10:G15"), WordDoc, "table1", False
WordDoc.SaveAs2 Filename:="C:\<pathway>\" & HosName & " " & _
Format((Year(Now() + 1) Mod 100), "20##") & _
Format((Month(Now() + 1) Mod 100), "0#") & _
Format((Day(Now()) Mod 100), "0#") & "-report.docx", _
FileFormat:=wdFormatXMLDocument
WordDoc.Close
Next c
End Sub
'transfer/copy data from a Range into a named bookmark in doc
' either directly as text or copy/paste as table
Sub CopyToBookmark(rng As Range, doc As Word.document, bmk As String, _
Optional AsValue As Boolean = True)
If AsValue Then
doc.bookmarks(bmk).Range.Text = rng.Value
Else
rng.Copy
doc.bookmarks(bmk).Range.Paste
End If
End Sub

Copy a specific Range to a Word Document

Instead of UsedRange, how do I copy the exact cell range from Excel to a Word document?
Sub export_excel_to_word()
Set obj = CreateObject("Word.Application")
obj.Visible = True
Set newObj = obj.Documents.Add
ActiveSheet.UsedRange.Copy
newObj.Range.Paste
Application.CutCopyMode = False
obj.Activate
newObj.SaveAs Filename:=Application.ActiveWorkbook.Path & "\" & ActiveSheet.Name
End Sub
This should be pretty easy to do. Just set a reference to word and run the script below. Of course, feel free to modify the script to suit your specific needs.
Sub ExcelRangeToWord()
'PURPOSE: Copy/Paste An Excel Table Into a New Word Document
'NOTE: Must have Word Object Library Active in Order to Run _
(VBE > Tools > References > Microsoft Word 12.0 Object Library)
'SOURCE: www.TheSpreadsheetGuru.com
Dim tbl As Excel.Range
Dim WordApp As Word.Application
Dim myDoc As Word.Document
Dim WordTable As Word.Table
'Optimize Code
Application.ScreenUpdating = False
Application.EnableEvents = False
'Copy Range from Excel
Set tbl = ThisWorkbook.Worksheets(1).Range("A1:J10")
'Create an Instance of MS Word
On Error Resume Next
'Is MS Word already opened?
Set WordApp = GetObject(class:="Word.Application")
'Clear the error between errors
Err.Clear
'If MS Word is not already open then open MS Word
If WordApp Is Nothing Then Set WordApp = CreateObject(class:="Word.Application")
'Handle if the Word Application is not found
If Err.Number = 429 Then
MsgBox "Microsoft Word could not be found, aborting."
GoTo EndRoutine
End If
On Error GoTo 0
'Make MS Word Visible and Active
WordApp.Visible = True
WordApp.Activate
'Create a New Document
Set myDoc = WordApp.Documents.Add
'Copy Excel Table Range
tbl.Copy
'Paste Table into MS Word
myDoc.Paragraphs(1).Range.PasteExcelTable _
LinkedToExcel:=False, _
WordFormatting:=False, _
RTF:=False
'Autofit Table so it fits inside Word Document
Set WordTable = myDoc.Tables(1)
WordTable.AutoFitBehavior (wdAutoFitWindow)
EndRoutine:
'Optimize Code
Application.ScreenUpdating = True
Application.EnableEvents = True
'Clear The Clipboard
Application.CutCopyMode = False
End Sub

Resources