I'm working with the below code that copies and pastes a bunch of named ranges from Excel to Word as pictures which already saves me a bunch of time.
To really cap it off I'm wondering if there is a way to insert these images at set places within a word document?
Sub copypaste()
'Create new word document
Dim objWord As Object
Dim objDoc As Object
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
Set objDoc = objWord.documents.Add()
Dim intCounter As Integer
Dim rtarget As Word.Range
Dim wbBook As Workbook
Set wbBook = ActiveWorkbook
'Loop Through names
For intCounter = 1 To wbBook.Names.Count
Debug.Print wbBook.Names(intCounter)
With objDoc
Set rtarget = .Range(.Content.End - 1, .Content.End - 1)
'Insert page break if not first page
If intCounter > 1 Then rtarget.insertbreak Type:=wdPageBreak
'Write name to new page of word document
rtarget.Text = wbBook.Names(intCounter).Name & vbCr
'Copy data from named range
Range(wbBook.Names(intCounter)).Copy
Set rtarget = .Range(.Content.End - 1, .Content.End - 1)
rtarget.PasteSpecial , DataType:=wdPasteMetafilePicture
End With
Next intCounter
End Sub
Related
My goal is to copy a multiline formatted text from a cicle of Word documents and paste it to an Excel worksheet into one single cell with in the first column the title of the document and in the second column the entire document using a VBA macro.
Now I've got a multiline text which needs more cells and get overrided.
This is my current code:
Sub Excel_Word()
Dim WordApp As Object 'New Word.Application
Dim objDoc As Object ' New Word.Document
Dim Range As Object 'Word.Range
Dim WordDoc As String
Dim sPath As String
Dim i As Long
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True
sPath = "C:\Users\gabri\Desktop\Test\"
WordDoc = Dir(sPath & "*.docx")
Do While WordDoc <> ""
Set objDoc = WordApp.Documents.Open(sPath & WordDoc)
objDoc.Range.Copy
i = i + 1
Foglio1.Cells(i, 1) = objDoc.Name
Foglio1.Cells(i, 2).PasteSpecial xlPasteValues
WordDoc = Dir()
Loop
WordApp.Quit
'elimina variabili
Set WordApp = Nothing
Set objDoc = Nothing
End Sub
Any ideas how I can handle this or any input?
I'd like to open a bunch of word files, from a list of file names in my excel workbook, activate the opened word files, perform a text replacement, and save the changes.
I can't make the liaison between Excel VBA and Word files.
Dim wdApp As Object, wddoc As Object
'Declare a string variable for Word document
Dim strDocName As String
On Error Resume Next
Set wdApp = CreateObject("Word.Application")
wdApp.Visible = True
strDocName = xDPathStr \ "FILENAME.docx" '(xDPathStr is the path I have defined earlier with all the word files)'
'Open Word File
wdApp.Activate
Set wddoc = wdApp.Documents(strDocName)
If wddoc Is Nothing Then Set wddoc = wdApp.Documents.Open(strDocName)
wddoc.Activate
wrdApp.Visible = True
Modify Word Files From a List in Excel
It is assumed that the file names are in column A. It will open each file and replace all occurrences of one string with another.
The focus here is on how to reference (open) Word, open files, modify them (not so much), close them with saving changes, and finally close Word only if it was initially closed.
Option Explicit
Sub VisitWord()
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Late Binding (not recommended at this stage)
' When you get familiar with how it works, switch to Late Binding:
' Dim wdApp As Object
' Dim WordWasClosed As Boolean
' On Error Resume Next ' see if Word is open
' Set wdApp = GetObject(, "Word.Application") ' attempt to create a reference to it
' On Error GoTo 0
' If wdApp Is Nothing Then ' Word is not open
' WordWasClosed = True
' Set wdApp = CreateObject("Word.Application") ' open and create a reference to it
' End If
' wdApp.Visible = True ' default is false; outcomment when done testing
' Dim wdDoc As Object
' ' etc.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Early Binding
' For this to work, in Excel, you need to create a reference to
' Tools > References > Microsoft Word 16.0 Object Library
' Use this to have the Word intellisense work for you.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Const WordFolderPath As String = "C:\Test\"
Const FINDSTRING As String = "Old String"
Const REPLACESTRING As String = "New String"
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")
Dim rg As Range
Set rg = ws.Range("A2", ws.Cells(ws.Rows.Count, "A").End(xlUp))
Dim wdApp As Word.Application
Dim WordWasClosed As Boolean
On Error Resume Next ' see if Word is open
Set wdApp = Word.Application ' attempt to create a reference to it
On Error GoTo 0
If wdApp Is Nothing Then ' Word is not open
WordWasClosed = True
Set wdApp = New Word.Application ' open and create a reference to it
End If
wdApp.Visible = True ' default is false; outcomment when done testing
Dim cell As Range
Dim wdDoc As Word.Document
Dim WordFileName As String
Dim WordFilePath As String
For Each cell In rg.Cells
WordFileName = CStr(cell.Value)
If Len(WordFileName) > 0 Then
WordFilePath = WordFolderPath & WordFileName
If Len(Dir(WordFilePath)) > 0 Then ' file exists
Set wdDoc = wdApp.Documents.Open(WordFilePath)
' Here you do the damage...
wdDoc.Content.Find.Execute _
FindText:=FINDSTRING, _
ReplaceWith:=REPLACESTRING, _
Format:=True, _
Replace:=wdReplaceAll
wdDoc.Close SaveChanges:=True
End If
End If
Next cell
If WordWasClosed Then wdApp.Quit
End Sub
So this is the code i've come up with so far:
Dim wdApp As Object, wddoc As Object
'Declare a string variable for Word document
Dim strDocName As String
On Error Resume Next
Set wdApp = CreateObject("Word.Application")
wdApp.Visible = True
strDocName = xDPathStr \ "FILENAME.docx" '(xDPathStr is the path I have defined earlier with all the word files)'
'Open Word File
wdApp.Activate
Set wddoc = wdApp.Documents(strDocName)
If wddoc Is Nothing Then Set wddoc = wdApp.Documents.Open(strDocName)
wddoc.Activate
wrdApp.Visible = True
Here is some sample code that I created recently to loop through cells in Excel, which are paths to Word files. Each Word file is opened, scanned for a table (in Word), and copy/paste to Excel. See if you can start with this. Post back if you have additional questions.
Sub LoopThroughAllWordFiles()
Dim wdApp As New Word.Application, wdDoc As Word.Document
Dim oTbl As Word.Table
Dim strFolder As String, strFile As String
Dim WkSht As Worksheet
Dim cnt As Long
Dim tableCount As Long
Dim lrow As Long
Dim lastrow As Long
Dim file As String
Dim rng As Range, cell As Range
Dim objDoc As Object
Dim objWord As Object
Dim StartTime As Double
Dim SecondsElapsed As Double
StartTime = Timer
Set rng = Worksheets("Files").Range("A1:A200")
Worksheets("Word_Tables").Select
filecounter = 1
cnt = 1
Set objWord = CreateObject("Word.Application")
obj.Word.Visible = False
For Each cell In rng.SpecialCells(xlCellTypeVisible)
MyStr = Right(cell, 5)
If MyStr = ".docx" Then
mylength = Len(cell)
pos = InStrRev(cell, "\")
strFolder = Left(cell, pos)
strFile = Right(cell, mylength - pos)
Worksheets("Word_Files").Select
Set objWord = wdApp.Documents.Open(Filename:=strFolder & strFile, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
Set sht = ThisWorkbook.Worksheets("Word_Files")
lastrow = Worksheets("Word_Files").UsedRange.Rows.Count + 1
totTbl = objDoc.Tables.Count
Debug.Print totTbl
For Each oTbl In objDoc.Tables
strCellText = oTbl.cell(1, 1).Range.Text
strCellText = LCase(strCellText)
Debug.Print strCellText
If strCellText Like "*data input*" Then
Worksheets("Word_Files").Range("A" & lastrow) = strFolder & strFile
On Error Resume Next
If cnt = 1 Then
lastrow = lastrow
Else
lastrow = ActiveSheet.UsedRange.Rows.Count
End If
oTbl.Range.Copy
Range("B" & lastrow).Select
sht.Paste
cnt = cnt + 1
End If
Next oTbl
End If
filecounter = filecounter + 1
Debug.Print filecounter
objWord.Close
Next cell
objDoc.Quit
Set objDoc = Nothing
objWord.Quit
Set objWord = Nothing
SecondsElapsed = Round(Timer - StartTime, 2)
SecondsFinal = SecondsElapsed / 60
MsgBox ("Code ran in " & SecondsFinal & "minutes.")
End Sub
to do that i started with the microsoft word 16.0 object library.
I need to take the value of the E10 cell (number). Who said how many lines i will have in my hostname's column.
to just copy that range of cells and export each one of those strings in a label formated word.
At the time this code insert all the value just in the first label with <> and not each strings to each label...
Thanks you.
Excel
Word labels template
Sub LabelMerge()
Dim oWord As Word.Application, oDoc As Word.Document
Dim strFile As String
Dim sPath As String
Dim i As Integer
Dim oHeaders As Range 'tab var data
Set oHeaders = Range("D48").CurrentRegion.Rows(1) 'select data from excel
sPath = ThisWorkbook.FullName 'path acces
Set oWord = CreateObject("Word.Application") 'create object word
'Set oDoc = oWord.Documents.add
Set oDoc = oWord.Documents.Open("file.docx")
oWord.Visible = True
oDoc.MailMerge.MainDocumentType = wdMailingLabels 'publipostage
'oWord. Dialogs (wdDialogLabeloptions) .Show
'oDoc.Activate
Dim x As Integer
x = 48 + Range("E10").Value
With oDoc.MailMerge.Fields
For i = 48 To x 'while i < lenght data
.Add oWord.Selection.Range, Cells(i, 4).Value
'oWord.Selection.TypeParagraph ‘OR: TypeText " "
Next i
End With
oDoc.MailMerge.OpenDataSource sPath
oWord.WordBasic.mailmergepropagatelabel
oDoc.MailMerge.ViewMailMergeFieldCodes = False
oDoc.ActiveWindow.View.ShowFieldCodes = False
'oDoc.MailMerge.Destination = wdSendToNewDocument 'add to doc
'oDoc.MailMerge.Execute
Set oDoc = Nothing
Set oWord = Nothing
End Sub
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
Hi I am using the following code to copy values from an excel worksheet into a predefined table in word. The below works fine for 1 column, how can I get it to tranfer the data for all 5 columns? Thanks
Sub ExportData()
Dim wdApp As Word.Application
Dim wdDoc As Word.Document
Dim wdCell As Word.Cell
Dim i As Long
Dim wbBook As Workbook
Dim wsSheet As Worksheet
Dim rnData As Range
Dim vaData As Variant
Set wbBook = ThisWorkbook
Set wsSheet = wbBook.Worksheets("Sheet1")
With wsSheet
Set rnData = .Range("A1:E10")
End With
'Add the values in the range to a one-dimensional variant-array.
vaData = rnData.Value
'Here we instantiate the new object.
Set wdApp = New Word.Application
'Here the target document resides in the same folder as the workbook.
Set wdDoc = wdApp.Documents.Open(ThisWorkbook.Path & "\Test.doc")
'Import data to the first table and in the first column of a table in Microsoft Word.
For Each wdCell In wdDoc.Tables(1).Columns(1).Cells
i = i + 1
wdCell.Range.Text = vaData(i, 1)
Next wdCell
'Save and close the document.
With wdDoc
.Save
.Close
End With
'Close the hidden instance of Microsoft Word.
wdApp.Quit
'Release the external variables from the memory
Set wdDoc = Nothing
Set wdApp = Nothing
MsgBox "The data has been transfered to Test.doc, vbInformation"
End Sub
So this is a bit of a late answer, but try the following:
Add to declarations
Dim j As Long
Remove from declarations
Dim rnData As Range
Change
With wsSheet
Set rnData = .Range("A1:E10")
End With
'Add the values in the range to a one-dimensional variant-array.
vaData = rnData.Value
to
ReDim vaData(1 To 10, 1 To 5)
With wsSheet
vaData = .Range("A1:E10")
End With
And change
'Import data to the first table and in the first column of a table in Microsoft Word.
For Each wdCell In wdDoc.Tables(1).Columns(1).Cells
i = i + 1
wdCell.Range.Text = vaData(i, 1)
Next wdCell
to
For j = 1 To 5
i = 0
For Each wdCell In wdDoc.Tables(1).Columns(j).Cells
i = i + 1
wdCell.Range.Text = vaData(i, j)
Next wdCell
Next j
A correction
MsgBox "The data has been transferred to Test.doc", vbInformation