I need to copy name and last name from Excel, paste it into a Word template and print. I have an Excel file from which I need to copy two columns from each row (i.e. E31:F31,E40:F40) into a bookmark in Word and then print it.
I need to loop either from row X to Y or X number of times. The Excel file is not well formatted. I managed to apply paste&print to a custom number of cells, but I get an error probably because I try to do it all at once.
document is in use do you want to open a temp copy
Copied text shows up in Word with big gaps between two words (what came from columns E and F). How do I fix?
Sub Copy_Excel_Cell_to_Word_Form()
Dim wdApp As Object 'Word.Application
Dim wdDoc As Object 'Word.Document
For i = 31 To 60
'Open new instance of Microsoft Word
Set wdApp = CreateObject("Word.Application")
'Make application visible
'wdApp.Visible = False
'Open the word document
Set wdDoc = wdApp.Documents.Open("\\example.doc")
'Copy value
Worksheets(1).Range("E" & i, "F" & i).Copy
'Paste to word document
wdDoc.Bookmarks("WORKER").Range.PasteAndFormat (wdFormatPlainText)
wdDoc.PrintOut
Next
End Sub
For your second point, try this:
Declare a string variable called workerName. Instead of Worksheets(1).Range("E" & i, "F" & i).Copy use
workerName = Worksheets(1).Cells(i,5).Value 'e = 5
workerName = workerName & " " & Worksheets(1).Cells(i,6).Value & vbCr 'f = 6
And instead of use wdDoc.Bookmarks("WORKER").Range.PasteAndFormat (wdFormatPlainText) use
wdDoc.Bookmarks("WORKER").Range.Text = workerName
This should clear up the big gaps.
Related
I am trying to copy a bunch of text data from an excel spreadsheet into multiple separate word documents (one excel row = one document, but each column's heading has to be included before the text from the respective field of the row). I also want these documents' names to be the text from specific fields in the spreadsheet (row headers).
Because I want fancy formatting, and a specific order of copying/pasting things (not all fields are included), I am using a word template with bookmarks that I can feed into VBA. It fills the template well, but I cannot save it as a standard word document before repeating the loop. I get the error 'Object doesn't support this property or method'. Is there a way to overcome it, or a more elegant method I've missed?
Here is the code:
Sub Primitive()
Dim objWord As Object
Dim ws As Worksheet
Dim i As Integer
Set ws = ThisWorkbook.Sheets("Sheet1")
i = 2 ' First row to process
'Start of loop
Do Until ws.Range("B" & i) = ""
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
'Change to local path of template file
objWord.Documents.Open "C:path of template file.dotx"
With objWord.ActiveDocument
.Bookmarks("FirstBookmark").Range.Text = ws.Range("B" & i).Value & " " & ws.Range("C" & i)
.Bookmarks("headlineZ").Range.Text = ws.Range("Z1").Value
lots of this^ here to arrange the data right in the document
NewFileName = "C:\path of where I want the new file" & ws.Range("C" & i).Value & ".docx"
This is the line that gives the error 483:
objWord.SaveAs2 Filename:="NewFileName"
End With
objWord.Close
Set objWord = Nothing
i = i + 1
Loop
End Sub
You are trying to save Word, rather than the document. If you replace this
objWord.SaveAs2 Filename:="NewFileName"
with this
objWord.ActiveDocument.SaveAs2 Filename:="NewFileName"
it should work better. That said, you should not use ActiveDocument in your macros. Consider replacing
objWord.Documents.Open "C:path of template file.dotx"
with something like
Set TargetDocument = objWord.Documents.Open("C:path of template file.dotx")
and replace all ActiveDocument with TargetDocument.
Good afternoon,
I have an Outlook .msg email saved at a local folder in my computer.
Is there any way I can replace the word "AAAA" in the body with any word I want in VBA?
Is there any way I can change the To: field?
The goal is to run an Excel table and create copies of a template message, replace the To: field and some words of the template with the info in the Excel table and save it. We will manually send latter.
I only need the .msg file modifying code (To: field and body replaces). The loop is already coded.
Thank you so much,
The Outlook object model doesn't provide anything to edit MSG files out of the box. But you can automate Outlook to create an item, edit it and then save it back as a template.
Use the Application.CreateItemFromTemplate method which creates a new Microsoft Outlook item from an Outlook template (.oft) and returns the new item. So, you can create a new item based on the template saved on the disk and then replace everything you need there. Then you could save it back as a template or send the item out. Read more about that in the How To: Create a new Outlook message based on a template article.
You can use Application.Session.OpenSharedItem to open an MSG file, modify the returned MailItem object (Subject / HTMLBody / Recipients), then call MAilItem.Save to update the MSG file.
If anyone needs, here it is the code I used. Do not focus on the for loops, but in the way the msg is loaded, edited and saved.
In this example some words in the msg file are replaced for the values in an excel table, as well as the TO: (email receiver). e.g. word AA in a msg file is changed with the value of the C7 cell.
The aim is to create a msg as a template with some key words (AA, BB, CC, etc), copy that template, replace those words with the ones in the excel table and save the new msg file.
Sub Recorrer()
Dim x As Integer
Dim fsObject As Object
Dim outApp As Object 'Outlook.Application
Dim outEmail As Object 'Outlook.MailItem
Dim outRecipient As Object 'Outlook.Recipient
On Error Resume Next
Set outApp = GetObject(, "Outlook.Application")
If outApp Is Nothing Then
MsgBox "Outlook is not open"
Exit Sub
End If
On Error GoTo 0
Set fsObject = CreateObject("Scripting.FileSystemObject")
' Set numcols = number of cols to be replaced.
NumCols = Range("C1", Range("C1").End(xlToRight)).Cells.Count
' Set numrows = number of rows of data.
NumRows = Range("A2", Range("A2").End(xlDown)).Rows.Count
' Select cell a1.
Range("A2").Select
' Establish "For" loop to loop "numrows" number of times.
For x = 1 To NumRows
fsObject.CopyFile ThisWorkbook.Path & "\" & Range("B" & x + 1) & ".msg", ThisWorkbook.Path & "\Correos\" & Range("B" & x + 1) & "_" & Range("C" & x + 1) & ".msg"
Set outEmail = outApp.Session.OpenSharedItem(ThisWorkbook.Path & "\Correos\" & Range("B" & x + 1) & "_" & Range("C" & x + 1) & ".msg")
outEmail.Recipients.Add Range("A" & x + 1)
For Z = 1 To NumCols
'MsgBox Cells(x + 1, Z + 2)
outEmail.HTMLBody = Replace(outEmail.HTMLBody, Cells(1, Z + 2), Cells(x + 1, Z + 2))
Next
outEmail.Save
' Selects cell down 1 row from active cell.
ActiveCell.Offset(1, 0).Select
Next
End Sub
i wrote the following code in VBA. I'm able to save the template onto the disk but the changes made are also made on the template which is then saved. I want to save the template with the information separately onto the disk and close the template without any changes being made to it. Also after I insert the details into header / footer, i used code to close the header / footer pane. That no longer works and now shows an extra page since i have separate header / footer for each page. How can i do this with the embedded word template since this worked if i kept the word template outside
Private Sub M114_Click()
Dim oleObject As Object
Dim wDoc As Object
Set oleObject = ActiveWorkbook.Sheets("Properties").OLEObjects(1)
oleObject.Verb Verb:=xlPrimary
ActiveSheet.Range("A1").Select
Set wDoc = oleObject.Object
' Creates the last row that will be used
'lRow = ThisWorkbook.Sheets("Input").Cells(Rows.Count, 1).End(xlUp).Row
' Loop through all the rows
'For i = 3 To lRow
i = 3
' Control 1/21 - Date of Letter
wDoc.ContentControls(1).Range.Text = ThisWorkbook.Sheets("Input").Cells(i, 2)
wDoc.ContentControls(21).Range.Text = ThisWorkbook.Sheets("Input").Cells(i, 2)
' Control 2/14 - Bank Contact Name
wDoc.ContentControls(2).Range.Text = ThisWorkbook.Sheets("Input").Cells(i, 13)
wDoc.ContentControls(14).Range.Text = ThisWorkbook.Sheets("Input").Cells(i, 13)
' Update Headers from page 3 to page 5
For j = 3 To 5
With wDoc.Sections(j).Headers(wdHeaderFooterPrimary).Range
.InsertAfter Text:=vbCrLf & UCase(ThisWorkbook.Sheets("Input").Cells(i, 6))
.InsertAfter vbTab
.InsertAfter Text:=vbCrLf & vbCrLf & UCase(ThisWorkbook.Sheets("Input").Cells(i, 7))
.InsertAfter vbTab
.InsertAfter Text:=vbCrLf & vbCrLf & ("At close of business on 31 December " & DatePart("yyyy", ThisWorkbook.Sheets("Input").Cells(i, 4)))
End With
Next j
'''' Issue with this resolve this
' Close the header / footer pane
wDoc.ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
wDoc.ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
' Create the file name and save and close the file
file_name = Application.WorksheetFunction.Trim("BankConf-" & ThisWorkbook.Sheets("Input").Cells(i, 6) & "-" & ThisWorkbook.Sheets("Input").Cells(i, 7) & ".doc")
wDoc.SaveAs2 (ThisWorkbook.Path & "/" & file_name)
'wDoc.ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
wDoc.Application.Quit
Side comment first: usually one would do what you want with mail merge in word ...
Regarding your question:
First of all - you should add a document (docx) as oleobject not a template (dotx). The template shows a somewhat strange behaviour.
Second it is necessary that you first do the saveAs, then open the new file to a separate doc-variable. By that the original oleObject-doc will not be edited.
Furthermore I would suggest two enhancements that make your code much more readable and more robust:
Insert a table for your data (= listobject in VBA) - then you can address the column-names in the code which is easier to maintain and to read than .cells(i,6).
You then can use these column names as tags for the content controls (ccs) in the word document. It is possible to name two different ccs with the same tag name. There is a method selectContentControlsByTag that returns all ccs with the same tag-name. Even those from headers and footers. So you should according ccs in the headers as well.
(Referencing a cc by index is critical as the index may change if you add a new cc or move them around or add text or ...)
As I understand you only insert some of the values to the letter. Therefore I suggest to postfix these column names e.g. by _cc.
This is the modified code - I added Microsoft Word as a reference to the VBA project.
Option Explicit
Sub createAll()
Dim docSource As Word.Document
Set docSource = getSourceDoc 'from oleObject
'assumption your data are in a table --> insert > table
'column names that have values that should go into the letter are named [CC-Tag]_CC
'example: columns name = DateOfLetter_CC | content controls tag= DateOfLetter
Dim lo As ListObject
Set lo = ThisWorkbook.Sheets("Input").ListObjects(1)
Dim lr As ListRow, lc As ListColumn
Dim docTarget As Word.Document, cc As ContentControl
'loop all rows of data table
For Each lr In lo.ListRows
'get empty word doc for this entry
Set docTarget = getTargetDoc(docSource, getFullFilename(lr))
For Each lc In lo.ListColumns
'within the word doc each CC has an according tag (without postfix)
If Right(lc.Name, 3) = "_CC" Then
For Each cc In docTarget.SelectContentControlsByTag(Split(lc.Name, "_")(0))
'there can be multiple CCs with the same tag
'tags within headers/footers are also handled within this loop
cc.Range.Text = lr.Range.Cells(1, lc.Index)
Next
End If
Next
docTarget.Close True
Next
'close Word
docSource.Application.Quit
MsgBox "ready"
End Sub
Private Function getFullFilename(lr As ListRow) As String
'you have to adjust this to your needs, i.e. add the correct column names to build the filename
Dim lo As ListObject
Set lo = lr.Parent
With lr.Range
getFullFilename = ThisWorkbook.Path & "\" & .Cells(1, lo.ListColumns("BankContactName_CC").Index).Value & ".docx"
End With
End Function
Private Function getSourceDoc() As Word.Document
'retrieves the oleDoc which is later used to save copies from
Dim oleObject As oleObject
Set oleObject = ThisWorkbook.Sheets("Properties").OLEObjects(1)
oleObject.Verb xlVerbOpen
Set getSourceDoc = oleObject.Object
End Function
Private Function getTargetDoc(docSource As Word.Document, FullFilename As String) As Word.Document
'saveas new file - open new file
'this is then returned
docSource.SaveAs2 FullFilename
Dim wrdApp As Word.Application
Set wrdApp = docSource.Application
Set getTargetDoc = wrdApp.Documents.Open(FullFilename)
End Function
Hi this is a follow up question from my previous question: Insert text to Word from Excel looping through drop down list
In addition to inserting text, I need to insert graphs for every region and copy the graph under each text. The graphs changes with the data for every region and is located next to the data table.
So the result has to look like this:
Text 1
Graph 1
Text 2
Graph 2 etc.
The code that inserts text (see from the previous question):
Sub Export()
Dim reg As Variant, col As String, txt As String
With ThisWorkbook.Sheets("Sheet 1")
For Each reg In Array("Region1", "Region2", "Region3")
.Range("B3") = reg
.Calculate
col = IIf(.Range("D2").Value = 14, "C", "D") 'select column due to D2 value
' collect all texts in txt
txt = txt & vbTab & "For " & reg & ", on June, 21 the estimate was " & _
.Range(col & "6").Text & " and the volume was " & .Range(col & "7").Text & _
" and the variance was " & .Range(col & "8").Text & vbLf
Next
End With
With CreateObject("Word.Application").Documents.Add
.Range.Text = txt ' output all text to the document
.SaveAs "C:\temp\AllTheText.docx" ' your path and name
.Parent.Quit 'quit Word
End With
End Sub
Sorry this isn't a bonafide answer, I don't have the reputation to ask a follow up question...
Have you considered copying the chart from Excel into Word, then issuing a Refresh command on the chart in Word once data is updated in Excel? You could then create a "AlltheTextTemplate" Word file with the charts preset. You'd then just create a copy of the template when creating a new report, fill it in with the data, and create a small bit of code to refresh the chart object.
Here's a few lines you could add:
Set wordapp = CreateObject("Word.Application")
' Path listed here assumes the template is stored in the same DIR as the workbook
Set objDoc = wordapp.documents.Open(Application.ThisWorkbook.Path & "\Template.docx")
wordapp.Visible = True 'Remove if you don't need to see it
With ObjDoc
.Range.Text = txt ' output all text to the document
.InlineShapes(1).LinkFormat.Update 'update the shape ID as needed
.InlineShapes(1).LinkFormat.BreakLink 'If you want to break the data link
.SaveAs "C:\temp\AllTheText.docx" ' your path and name
.Parent.Quit 'quit Word
End With
Admittedly new to VBA. I have an excel file that consists of all our part numbers broken down by "-" marks that I wrote code to break down into more descriptive phrases for making labels. I am trying to write code here to loop through different types of part numbers, grab particular cells in that part #'s row and copy/pasting them into a word document and saving the word doc as the part #'s name. As is, it loops but grabs all the info from the different ranges instead of just the info from the same row as part.
The code works (besides saving) if I change the ranges to 1 single cell, but once I have multiple cells in the ranges, it begins copying everything in the range instead of just in the row of the part that it should be looping.
Sub exceltoword2()
Dim part As Range
Dim funct As Range
Dim finish As Range
Dim lever As Range
Dim backset As Range
Dim trim As Range
Set part = Range("A2:A5")
Set funct = Range("Q2:Q5")
Set finish = Range("R2:R5")
Set lever = Range("S2:S5")
Set backset = Range("T2:T5")
Set trim = Range("U2:U5")
Dim wdapp As Word.Application
Set wdapp = New Word.Application
Dim SaveName As String
Dim path As String
path = "C:\Users\bpickett\Desktop\Parts\"
For Each part In part 'Long list of part #'s that will be looped through with particular variables commented out as needed as I adjust range on part variable
With wdapp
.Visible = True
.Documents.Add
.Activate
part.Copy '********************************Part copied
.Selection.PasteSpecial
With .Selection '**********************Function copied
.Font.Name = "Calibri"
.Font.Size = 22
.TypeText "FUNCTION " '7 spaces
End With
funct.Copy
.Selection.PasteSpecial
With .Selection '**************************Finish
.Font.Name = "Calibri"
.Font.Size = 22
.TypeText "FINISH " '14 spaces
End With
finish.Copy
.Selection.PasteSpecial
With .Selection '***************************Backset
.Font.Name = "Calibri"
.Font.Size = 22
.TypeText "BACKSET " '10 spaces
End With
backset.Copy
.Selection.PasteSpecial
ActiveDocument.SaveAs2 path & part & ".docx"
End With
Next
End Sub
The code when ran has the 1st part # correct then, just copies the entire range of Backset/Function/Finish under each instead of just the single cell in the row of the part #.
Took advice from comments above and did a days more worth of research and made some changes that solved all problems.
For i = 1 to 1275
Set part = Range("A" & i)
Set funct = Range("Q" & i)
Set finish = Range("R" & i)
Set lever = Range("S" & i)
Set backset = Range("T" & i)
Set trim = Range("U" & i)
Qualifying the ranges(or at least to me it did) and adding the i array instead of for each part in part was huge for code to loop and grab only necessary information. But when running, it was crashing with error 4605 a lot. But a 7 year old question that was answered on here surrounded the copy/paste commands with labels and error handler
Pg1CopyAttempt:
DoEvents
part.Copy
On Error GoTo Pg1PasteFail
.selection.pastespecial
On Error goto 0 'disable the error handler
Pg1PasteFail:
If Err.Number = 4605 Then ' clipboard is empty or not valid.
DoEvents
Resume Pg1CopyAttempt
End If
Which worked FLAWLESSLY to go through strings of 100's or 1000's of loops(Files created). Just had to modify Pg1 to 2 to 3 and ect through code.