EDIT 1:
I'm trying to format paragraph with a string (today's date) with right align in VBA, using Excel VBA test function as below. This line below I thought was acceptable syntax but I got something wrong here or somewhere else in the function, as date still displays left-aligned when I open the saved document:
wordLetter.Paragraphs(1).Alignment = wdAlignParagraphRight
This function creates new Word document with Normal template, adds the date, saves it relative to current Excel workbook location.
Otherwise, I understand .Paragraphs(1) exists already when a Word document is created with .Add or .Open method of Documents collection, I only just realised this.
Private Function Test()
Dim objWord As Object: Set objWord = CreateObject("Word.Application")
objWord.Application.DisplayAlerts = False
objWord.Application.ScreenUpdating = False
Dim wordLetter As Object: Set wordLetter = objWord.Documents.Add
wordLetter.Range.Font.textColor.RGB = RGB(0, 0, 0)
Dim strDate As String: strDate = Format(Now(), "dddd, mmm d, yyyy")
wordLetter.Paragraphs(1).Alignment = wdAlignParagraphRight
wordLetter.Paragraphs(1).Range.text = strDate
objWord.Application.ScreenUpdating = True
savePath = ThisWorkbook.path & "\testDoc.docx"
With wordLetter
.SaveAs2 Filename:=savePath, FileFormat:=wdFormatDocumentDefault
End With
Application.DisplayAlerts = True
End Function
Many thanks any suggestions.
WordLetter.Paragraphs(1).Alignment = wdAlignParagraphRight
Related
My Task
Split a Word document into multiple parts based on a delimiter while preserving the text format.
Where I am?
I tried a basic example with one document but without an array and it worked.
Option Explicit
Public Sub CopyWithFormat()
Dim docDestination As Word.Document
Dim docSource As Word.Document
Set docDestination = ActiveDocument
Set docSource = Documents.Add
docSource.Range.FormattedText = docDestination.Range.FormattedText
docSource.SaveAs "C:\Temp\" & "test.docx"
docSource.Close True
End Sub
Where do I stuck?
I put the whole document into an array and loop through it. Right not I get an error 424 - Object necessary on this line:
docDestination.Range.FormattedText = arrNotes(I).
I also tried these four variants without luck:
docDestination.Range.FormattedText = arrNotes(I).Range.FormattedText
docDestination.Range.FormattedText = arrNotes(I).FormattedText
docDestination.Range.FormattedText = arrNotes.Range.FormattedText(I)
docDestination.Range.FormattedText = arrNotes.FormattedText(I)
Could you please help and point me into the right direction on how to access the array properly?
My Code
Option Explicit
Sub SplitDocument(delim As String, strFilename As String)
Dim docSource As Word.Document
Dim docDestination As Word.Document
Dim I As Long
Dim X As Long
Dim Response As Integer
Dim arrNotes
Set docSource = ActiveDocument
arrNotes = Split(docSource.Range, delim)
For I = LBound(arrNotes) To UBound(arrNotes)
If Trim(arrNotes(I)) <> "" Then
X = X + 1
Set docDestination = Documents.Add
docDestination.Range.FormattedText = arrNotes(I) 'throws error 424
docDestination.SaveAs ThisDocument.Path & "\" & strFilename & Format(X, "0000")
docDestination.Close True
End If
Next I
End Sub
Sub test()
'delimiter & filename
SplitDocument "###", "Articles "
End Sub
Range.FormattedText returns a range object. The Split function, on the other hand, returns an array of strings which don't include formatting. Therefore your code should find the portion of the document you wish to copy and assign that part's FormattedText to a variable declared as Range. That variable could then be inserted into another document.
Private Sub CopyRange()
Dim Src As Range, Dest As Range
Dim Arr As Range
Set Src = Selection.Range
Set Arr = Src.FormattedText
Set Dest = ActiveDocument.Range(1, 1)
Dest.FormattedText = Arr
End Sub
The above code actually works. All you would need to do is to find a way to replace the Split function in your concept with a method that identifies ranges in the source document instead of strings.
I am trying to add captions to a word document, using VBA. I am using the following code. The data starts off as tables in an Excel spreadsheet, with one per sheet. We are trying to generate a list of tables in the word document.
The following code loads starts editing a word template:
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
Set objDoc = objWord.Documents.Add("Template path")
' Moving to end of word document
objWord.Selection.EndKey END_OF_STORY, MOVE_SELECTION
' Insert title
objWord.Selection.Font.Size = "16"
objWord.Selection.Font.Bold = True
objWord.Selection.TypeText ("Document name")
objWord.Selection.ParagraphFormat.SpaceAfter = 12
objWord.Selection.InsertParagraphAfter
The following code loops through the sheets in the worksheet and adds the tables and headers.
' Declaring variables
Dim Wbk As Workbook
Dim Ws As Worksheet
Dim END_OF_STORY As Integer: END_OF_STORY = 6
Dim MOVE_SELECTION As Integer: MOVE_SELECTION = 0
Dim LastRow As Integer
Dim LastColumn As Integer
Dim TableCount As Integer
Dim sectionTitle As String: sectionTitle = " "
' Loading workbook
Set Wbk = Workbooks.Open(inputFileName)
' Moving to end of word document
objWord.Selection.EndKey END_OF_STORY, MOVE_SELECTION
' Looping through all spreadsheets in workbook
For Each Ws In Wbk.Worksheets
' Empty Clipboard
Application.CutCopyMode = False
objWord.Selection.insertcaption Label:="Table", title:=": " & Ws.Range("B2").Text
In the cell B2, I have the following text: "Table 1: Summary". I am hoping for the word document to have a header which reflects this text. The problem is the table number is repeated twice, and I get output: "Table 1: Table 1: Summary". I tried the following alterations, both of which resulted in errors:
objWord.Selection.insertcaption Label:="", title:="" & Ws.Range("B2").Text
objWord.Selection.insertcaption Label:= Ws.Range("B2").Text
What am I doing wrong, and more generally how does the insertcaption method work?
I have tried reading this, but am confused by the syntax.
https://msdn.microsoft.com/en-us/vba/word-vba/articles/selection-insertcaption-method-word
One of the built-in features of using the Caption style in MS Word is the automatic numbering it applies and dynamically adjust in your document. You are explicitly trying to manage the table numbering yourself - which is fine - but you'll then have to un-do some of Word's automatic helpful numbering in your code.
Working from Excel, I've tested the code below to set up a test document with Captions and then a quick routine to remove the automatic part of the label. This example code works as a stand-alone test to illustrate how I worked it, leaving it to you to adapt to your own code.
The initial test sub simply establishes the Word.Application and Document objects, then creates three tables with following paragraphs. Each of the tables has it's own caption (which shows the doubled up label, due to the automatic labeling from Word). The code throws up a MsgBox to pause so you can take a look at the document before it's modified.
Then the code goes back and searches the entire document for any Caption styles and examines the text within the style to find the double label. I made the assumption that a double label is present if there are two colons ":" detected in the caption text. The first label (up to and past the first colon) is removed and the text replaced. With that, the resulting document looks like this:
The code:
Option Explicit
Sub test()
Dim objWord As Object
Dim objDoc As Object
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
Set objDoc = objWord.documents.Add
Dim newTable As Object
Set newTable = objDoc.Tables.Add(Range:=objDoc.Range, NumRows:=3, NumColumns:=1)
newTable.Borders.Enable = True
newTable.Range.InsertCaption Label:="Table", Title:=": Table 1: summary xx"
objDoc.Range.InsertParagraphAfter
objDoc.Range.InsertAfter "Lorem ipsum"
objDoc.Characters.Last.Select
objWord.Selection.Collapse
Set newTable = objDoc.Tables.Add(Range:=objWord.Selection.Range, NumRows:=3, NumColumns:=2)
newTable.Range.InsertCaption Label:="Table", Title:=": Table 2: summary yy"
newTable.Borders.Enable = True
objDoc.Range.InsertParagraphAfter
objDoc.Range.InsertAfter "Lorem ipsum"
objDoc.Characters.Last.Select
objWord.Selection.Collapse
Set newTable = objDoc.Tables.Add(Range:=objWord.Selection.Range, NumRows:=3, NumColumns:=3)
newTable.Range.InsertCaption Label:="Table", Title:=": Table 3: summary zz"
newTable.Borders.Enable = True
objDoc.Range.InsertParagraphAfter
objDoc.Range.InsertAfter "Lorem ipsum"
MsgBox "document created. hit OK to continue"
RemoveAutoCaptionLabel objWord
Debug.Print "-----------------"
End Sub
Sub RemoveAutoCaptionLabel(ByRef objWord As Object)
objWord.Selection.HomeKey 6 'wdStory=6
With objWord.Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Style = "Caption"
.Text = ""
.Forward = True
.Wrap = 1 'wdFindContinue=1
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
Do While .Execute()
RemoveDoubleLable objWord.Selection.Range
objWord.Selection.Collapse 0 'wdCollapseEnd=0
Loop
End With
End Sub
Sub RemoveDoubleLable(ByRef capRange As Object)
Dim temp As String
Dim pos1 As Long
Dim pos2 As Long
temp = capRange.Text
pos1 = InStr(1, temp, ":", vbTextCompare)
pos2 = InStr(pos1 + 1, temp, ":", vbTextCompare)
If (pos1 > 0) And (pos2 > 0) Then
temp = Trim$(Right$(temp, Len(temp) - pos1 - 1))
capRange.Text = temp
End If
End Sub
I'm a complete newbie to VBA and would really appreciate some help automating a process, if anyone would be so kind. :)
I am trying to populate a Word template from an excel spreadsheet I have created
I have found some code which emables me to open my Word template, but that's as far as I'm capable of going :( lol
Private Sub PrintHDR_Click()
Dim objWord As Object
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
objWord.Documents.Open "C:\Users\Duncan\Desktop\HDR.dotx"
End Sub
The next step I wish to achieve is to copy and paste data from certain cells into my Word document.
I have set up the bookmarks in Word and have named the cells I wish to copy.
Some cells contain text, other cells contain formulas / sums which produce a numerical answer. In the cells that contain formulas or sums, it is the answer which I want copied to Word.
Any help would be much appreciated.
Thanks in advance :)
Duncan
I have code that does something like this. In Word, instead of using bookmarks for the fields to replace, I just use a special marker (like <<NAME>>).
You may have to adapt. I use a ListObject (the new Excel "Tables"), you can change that if you use a simple Range.
Create a "Template.docx" document, make it read-only, and place your replaceable fields there (<<NAME>>, etc.). A simple docx will do, it doesn't have to be a real template (dotx).
Public Sub WriteToTemplate()
Const colNum = 1
Const colName = 2
Const colField2 = 3
Const cBasePath = "c:\SomeDir"
Dim wordDoc As Object, sFile As String, Name As String
Dim lo As ListObject, theRow As ListRow
Dim item As tItem
Set lo = ActiveCell.ListObject
Set theRow = ActiveCell.ListObject.ListRows(ActiveCell.Row - lo.Range.Row)
With theRow.Range
'I use one of the columns for the filename:
Debug.Print "writing " & theRow.Range.Cells(1, colName).text
'A filename cannot contain any of the following characters: \ / : * ? " < > |
Name = Replace(.Cells(1, colName), "?", "")
Name = Replace(Name, "*", "")
Name = Replace(Name, "/", "-")
Name = Replace(Name, ":", ";")
Name = Replace(Name, """", "'")
sFile = (cBasePath & "\" & Name) & ".docx"
Debug.Print sFile
Set wordApp = CreateObject("word.Application")
If Dir(sFile) <> "" Then 'file already exists
Set wordDoc = wordApp.Documents.Open(sFile)
wordApp.Visible = True
wordApp.Activate
Else 'new file
Set wordDoc = wordApp.Documents.Open(cBasePath & "\" & "Template.docx")
wordApp.Selection.Find.Execute Forward:=(wordApp.Selection.Start = 0), FindText:="««NUM»»", ReplaceWith:=.Cells(1, colNum)
wordApp.Selection.Collapse direction:=1 'wdCollapseEnd
wordApp.Selection.Find.Execute FindText:="««NAME»»", ReplaceWith:=.Cells(1, colName)
wordApp.Selection.Collapse direction:=1 'wdCollapseEnd
wordApp.Selection.Find.Execute FindText:="««FIELD2»»", ReplaceWith:=.Cells(1, colField2)
wordDoc.ListParagraphs.item(1).Range.Select
wordApp.Selection.Collapse direction:=1 'wdCollapseEnd
wordApp.Visible = True
wordApp.Activate
On Error Resume Next
'if this fails (missing directory, for example), file will be unsaved, and Word will ask for name.
wordDoc.SaveAs sFile 'Filename:=(cBasePath & "\" & .Cells(1, colName))
On Error GoTo 0
End If
End With
End Sub
This basically replicates the Mail Merge function in code, to give you more control.
I'm trying to open two documents from excel with vba and call a word macro from this particular excel file.
The macro is working fine in Word and I also get the documents to open and the word macro to start. However when there is a switch from one document to the other the word macro goes to break-mode (which does not happen when I run it from Word instead of Excel).
I use the following code from excel:
Set wordApp = CreateObject("Word.Application")
worddoc = "H:\Word Dummy's\Dummy.docm"
wordApp.Documents.Open worddoc
wordApp.Visible = True
wordApp.Run macroname:="update_dummy", varg1:=client, varg2:=m_ultimo, varg3:=y
In word I have a sub with the parameters defined between breakets and the following code:
worddoc2 = "H:\Word Dummy's\texts.docx"
Word.Application.Activate
Documents.Open worddoc2, ReadOnly:=True
ThisDocument.Activate
Set bmks = ThisDocument.Bookmarks
Can anyone tell me why it does not run from excel and how I can fix this?
Thanks in advance.
I finally found the answer myself after a lot of searching on Google.
I needed to add :
application.EnableEvents=false
To the excel macro.
That was all. Now it works.
My complete code is huge (the macro in excel also opens two other workbooks and runs a macro in them). This part of the code is working for now (so I left it out), but I just want to add the part that it opens a worddoc and adds specific texts in it depending on what client has been chosen in the excel userform. But to show you a better idea how my code looks like, this is in excel (where the client is defined by a userform in another module):
Sub open_models (client as string)
Application.DisplayStatusBar = True
‘determine datatypes
Dim m_integer As Integer
Dim m_ultimo As String
Dim m_primo As String
Dim y As String
Dim y_integer As Integer
Dim y_old As String
Dim y_last As String
Dim wordApp As Object
Dim worddoc As String
'Determine current month and year and previous
m_integer = Format(Now, "mm")
y_integer = Format(Now, "yyyy")
If m_integer <= 9 Then
m_ultimo = "0" & m_integer - 1
m_primo = "0" & m_integer - 2
Else
m_ultimo = m_integer - 1
m_primo = m_integer - 2
End If
If m_integer = 1 Then
y = y_integer - 1
Else
y = y_integer
End If
On Error Resume Next
'open word dummy
Set wordApp = CreateObject("Word.Application")
worddoc = "H:\RAPORTAG\" & y & "\" & y & m_ultimo & "\Dummy.docm"
wordApp.Documents.Open worddoc
wordApp.Visible = True
wordApp.Run macroname:="update_dummy", varg1:=client, varg2:=m_ultimo, varg3:=y, varg4:= worddoc)
On Error GoTo 0
ThisWorkbook.Activate
'reset statusbar and close this workbook
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
ThisWorkbook.Close False
End Sub
And this is the code in word I am using:
Sub update_dummy(client As String, m_ultimo As String, y As String, worddoc as string)
Dim wordapp As Object
Dim rngStart As Range
Dim rngEnd As Range
Dim worddoc As String
Dim worddoc2 As String
Dim dekkingsgraad As String
Dim bmks As Bookmarks
Dim bmRange As Range
Dim rng As Range
Dim i As Boolean
On Error Resume Next
worddoc2 = "H:\RAPORTAG\" & y & "\" & y & m_ultimo & "\dummytexts.docx"
'open other word
Documents.Open worddoc2, ReadOnly:=True
Documents(worddoc).Activate
Set bmks = Documents(worddoc).Bookmarks
'management summary
If client <> "PMT" Then
i = True
Set rngStart = Documents(worddoc2).Bookmarks("bn0_1_start").Range
Set rngEnd = Documents(worddoc2).Bookmarks("bn0_1_end").Range
End If
If i = True Then
Set rng = Documents(worddoc2).Range(rngStart.Start, rngEnd.End)
rng.Copy
Set bmRange = Documents(worddoc).Bookmarks("bmManagementsummary").Range
bmRange.PasteAndFormat (wdPasteDefault)
End If
i = False
On Error GoTo 0
End Sub
I have 20 more bookmarks that are defined but the code for them is all the same.
I have seen and solved this problem a few times before, the solution I found was odd.
Copy paste all your code into a text
editor, 1 for word, 1 for excel
Delete all the macros in word or excel or better yet, just create
new files.
Paste all the code into word/excel from your text editor.
I've definitely had this 3 or 4 times in Excel and Access. Especially if you previously had a breakpoint at that location.
It sounds stupid but try it and see if that works, this has saved me from insanity a few times.
I have a VBA subroutine which performs miscellaneous formatting to Word documents. It relies on the Selection object (Selection.WholeStory) to apply the formatting.
This subroutine is called from VBA Outlook with a Word.Application object.
The problem that arises is: when another instance of Word is open when the macro is called, the Selection Object refers to the Word document already open, not the handler created in my macro.
VBA does not seem to qualify the selection objct, so when you write Selection.PageSetup (ie) and start applying changes, it is applied to the Document already open in Word, not the document you are handling from VBA.
I've looked around for the answer on MSDN and here, but to no luck. If anyone knows how to qualify this object, let me know. Thanks.
Basically,
create word handler
open attachment in word
Selection.WholeStory
With Selection.PageSetup
.LineNumbering.Active = False
.Orientation = wdOrientPortrait
/* etc */
End with
Since "Selection" cannot be qualified, all these changes get made to whatever is already open.
if numTextFiles >= 1 then
for each textFile in textFileNames
'Open text file in word
Set doc = WordApp.Documents.Open(outReportFullDir & "\" & textFile)
'Set the output name of word doc (change .txt to .docx)
reportWordName = left(textFile, len(textFile) - 4)
reportWordName = reportWordName & ".docx"
'Check if out word document already exists
preventOverwrite(outReportFullDir & "\" & reportWordName)
'Format Reports
formatReport()
'etc
_
Private Sub formatReport()
documents(docToFormat).select
Selection.WholeStory
'Added by Ryan to make single-spaced
WordBasic.OpenOrCloseParaBelow
WordBasic.OpenOrCloseParaBelow
Selection.Font.Name = "Courier New"
Selection.Font.Size = 8
With Selection.PageSetup
.MirrorMargins = False
.TwoPagesOnOne = False
.BookFoldPrinting = False
.BookFoldRevPrinting = False
.BookFoldPrintingSheets = 1
.GutterPos = wdGutterPosLeft
End With
End Sub
There is probably confusion between Word's selection object and Outlook's selection object.
Use
WordApp.Selection
i.e.
WordApp.Selection.WholeStory
WordApp.Selection.Font.Name = "Courier New"
etc.
(or e.g.
Dim sel as Word.Selection
Set sel = WordApp.Selection
sel.WholeStory
sel.Font.Name = "Courier New"
Set sel = Nothing
So that if WordApp is not in scope, you should be able to use something like
Set sel = doc.Application.Selection
)
Finally, if you can get away with using Word Range instead, I would do so (e.g. doc.Range or Doc.Content) and avoid the whole Selection thing.
Have you tried something like this? It looks like you're getting a proper reference to the correct document at one stage in the game.
if numTextFiles >= 1 then
for each textFile in textFileNames
'Open text file in word
Set doc = WordApp.Documents.Open(outReportFullDir & "\" & textFile)
'Set the output name of word doc (change .txt to .docx)
reportWordName = left(textFile, len(textFile) - 4)
reportWordName = reportWordName & ".docx"
'Check if out word document already exists
preventOverwrite(outReportFullDir & "\" & reportWordName)
'Format Reports
Call formatReport(doc)
'etc
Private Sub formatReport(ByRef doc)
documents(doc).select
Selection.WholeStory
'Added by Ryan to make single-spaced
WordBasic.OpenOrCloseParaBelow
WordBasic.OpenOrCloseParaBelow
Selection.Font.Name = "Courier New"
Selection.Font.Size = 8
With Selection.PageSetup
.MirrorMargins = False
.TwoPagesOnOne = False
.BookFoldPrinting = False
.BookFoldRevPrinting = False
.BookFoldPrintingSheets = 1
.GutterPos = wdGutterPosLeft
End With
End Sub