Inserting Header/Footer into newly created word document from Excel VBA - vba

I'm trying to create word document from content in Excel.
When I tryto add header/footer in the word, I'm getting an error "Run Time Error 5941 : The requested member of the collection does not exist" on line .Headers(wdHeaderFooterPrimary).Range.Text = "Header text". Please suggest how I can work with this?
Sub CreateFAQWord()
Dim myRow As Long
Dim objWord As Object
Dim objDoc As Object
Dim question As String
Dim answer As String
Dim rng As Range
Dim i As Long
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
Set objDoc = objWord.Documents.Add()
objWord.Selection.Style = objDoc.Styles("Title")
objWord.Selection.Paragraphs.Alignment = 1
objWord.Selection.TypeText Text:="Title"
objWord.Selection.TypeParagraph
objWord.Selection.TypeParagraph
With objDoc
.Styles.Add ("BoldNormal")
With .Styles("BoldNormal").Font
.Name = "Calibri"
.Size = 11
.Bold = True
.Italic = True
.Underline = False
End With
End With
myRow = 2
' Value 2 here is the column in which questions are present. Change accordingly
While Cells(myRow, 2).Value <> ""
' Value 9 here is the column in which Yes/No is present. Change accordingly
If Cells(myRow, 9) = "Yes" Then
objDoc.Activate
question = Cells(myRow, 2)
answer = Cells(myRow, 3)
objWord.Selection.Style = objDoc.Styles("BoldNormal")
objWord.Selection.TypeText Text:=question
objWord.Selection.TypeParagraph
objWord.Selection.Style = objDoc.Styles("Normal")
objWord.Selection.TypeText Text:=answer
objWord.Selection.TypeParagraph
objWord.Selection.TypeParagraph
End If
myRow = myRow + 1
Wend
For i = 1 To objDoc.Sections.Count
With objDoc.Sections(i)
.Headers(wdHeaderFooterIndex.wdHeaderFooterPrimary).Range.Text = "Header text"
.Footers(wdHeaderFooterIndex.wdHeaderFooterPrimary).Range.Text = "Footer text"
End With
Next
' Change the location path of where you want the document to be saved as needed
objDoc.SaveAs "C:\Users\2021282\Desktop\FAQ"
End Sub

I do not think you can use .Range.Text
Instead try to assign a reference to a range object. To make this work you need to add the "Microsoft Word XX.X Object Library" under references.
Dim objRange as Word.Range
For i = 1 To objDoc.Sections.Count
With objDoc.Sections(i)
Set objRange = .Headers(wdHeaderFooterIndex.wdHeaderFooterPrimary).Range
objRange = "Header Text"
Set objRange = Nothing
Set objRange = .Footers(wdHeaderFooterIndex.wdHeaderFooterPrimary).Range
objRange = "Footer text"
Set objRange = Nothing
End With
Next

Related

Display the final proposed text in Tracked Change without accepting the change

I am trying to write a Macro that can display the final proposed text in a tracked change without having to accept the change.
Current code (modified from thedoctools.com) is as follows which uses a Revision object only for Delete and Insert types:
Public Sub ExtractAllRevisionsToExcel()
Dim oDoc As Document
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim oNewExcel As Worksheet
Dim oRange As Range
Dim oRevision As Revision
Dim strText As String
Dim index As Long
Dim Title As String
Title = "Extract All revisions to Excel"
Set oDoc = ActiveDocument
If ActiveDocument.Revisions.Count = 0 Then
MsgBox "The active document contains no changes.", vbOKOnly, Title
GoTo ExitHere
End If
Application.ScreenUpdating = True
'Create a new excel for the revisions
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlWB = xlApp.Workbooks.Add 'create a new workbook
Set oNewExcel = xlWB.Worksheets(1)
With oNewExcel
.Cells(1, 1).Formula = "Document"
.Cells(1, 2).Formula = "Page"
.Cells(1, 3).Formula = "line number"
.Cells(1, 4).Formula = "Original Statement"
.Cells(1, 5).Formula = "Statement Proposed"
index = 1
'Get info from each tracked change (insertion/deletion) from oDoc and insert in table
For Each oRevision In oDoc.Revisions
Select Case oRevision.Type
'Only include insertions and deletions
Case wdRevisionInsert, wdRevisionDelete
'In case of footnote/endnote references (appear as Chr(2)),
'insert "[footnote reference]"/"[endnote reference]"
With oRevision
'Get the changed text
strText = .Range.Text
Set oRange = .Range
Do While InStr(1, oRange.Text, Chr(2)) > 0
'Find each Chr(2) in strText and replace by appropriate text
i = InStr(1, strText, Chr(2))
If oRange.Footnotes.Count = 1 Then
strText = Replace(Expression:=strText, _
Find:=Chr(2), Replace:="[footnote reference]", _
Start:=1, Count:=1)
'To keep track of replace, adjust oRange to start after i
oRange.Start = oRange.Start + i
ElseIf oRange.Endnotes.Count = 1 Then
strText = Replace(Expression:=strText, _
Find:=Chr(2), Replace:="[endnote reference]", _
Start:=1, Count:=1)
'To keep track of replace, adjust oRange to start after i
oRange.Start = oRange.Start + i
End If
Loop
End With
index = index + 1 'Add 1 to row
'Insert data in cells in row
'The document name
.Cells(index, 1).Formula = oDoc.FullName & vbCr
'Page number
.Cells(index, 2).Formula = oRevision.Range.Information(wdActiveEndPageNumber)
'Line number - start of revision
.Cells(index, 3).Formula = oRevision.Range.Information(wdFirstCharacterLineNumber)
'Original section text
.Cells(index, 4).Formula = oRevision.Range.Paragraphs(1).Range.Text
'Proposed changes - THIS IS WHERE I WANT TO SEE THE PREVIEW OF THE FINAL SECTION AFTER CHANGE IS ACCEPTED
If oRevision.Type = wdRevisionInsert Then
.Cells(index, 5).Formula = strText
'Apply automatic color (black on white)
.Cells(index, 5).Font.Color = wdColorBlue
Else
.Cells(index, 5).Formula = strText
'Apply red color
.Cells(index, 5).Font.Color = wdColorRed
End If
End Select
Next oRevision
End With
'Repaginate
ActiveDocument.Repaginate
'Toggle nonprinting characters twice
ActiveWindow.ActivePane.View.ShowAll = Not _
ActiveWindow.ActivePane.View.ShowAll
ActiveWindow.ActivePane.View.ShowAll = Not _
ActiveWindow.ActivePane.View.ShowAll
Application.ScreenUpdating = True
Application.ScreenRefresh
oNewExcel.Activate
MsgBox ActiveDocument.Revisions.Count & " changes found. Finished creating the worksheet.", vbOKOnly, Title
ExitHere:
Set oDoc = Nothing
Set xlWB = Nothing
Set xlApp = Nothing
Set oNewExcel = Nothing
Set oRange = Nothing
End Sub
The variable strText returns only the portion we are changing in oRevision.Range.Paragraphs(1).Range.Text, however I want a variable that returns the final text in oRevision.Range.Paragraphs(1).Range.Text AFTER the change has already been accepted, but without accepting the change in the actual Word document.
Is there a way to get such a variable as I just want to have a preview of the final section after the change is accepted, without accepting the change.
Even Word's macro recorder can give you the code for that:
With ActiveWindow.View
.ShowRevisionsAndComments = False
.RevisionsView = wdRevisionsViewFinal
End With

textbox moves to the top of last page in word document vba macro

I am writing a vba macro for a word document. I use vba macro to generate textbox and text to the word document. The issue is that the textbox moves to the top of last page instead of staying on the first page.
I don't know what i am doing wrong. All i need is for that textbox to remain on the first page. I really need to include the textbox.
below is my code and the output image
Dim wrdDoc As Object
Dim tmpDoc As Object
Dim WDoc As String
Dim myDoc As String
myDoc = "myTest"
WDoc = ThisDocument.Path & "\mydocument.docx"
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If wdApp Is Nothing Then
' no current word application
Set wdApp = CreateObject("Word.application")
Set wrdDoc = wdApp.Documents.Open(WDoc)
wdApp.Visible = True
Else
' word app running
For Each tmpDoc In wdApp.Documents
If StrComp(tmpDoc.FullName, WDoc, vbTextCompare) = 0 Then
' this is your doc
Set wrdDoc = tmpDoc
Exit For
End If
Next
If wrdDoc Is Nothing Then
' not open
Set wrdDoc = wdApp.Documents.Open(WDoc)
End If
End If
ActiveDocument.Content.Select
Selection.Delete
With wdApp
.Visible = True
.Activate
With .Selection
Dim objShape As Word.Shape
Set objShape2 = ActiveDocument.Shapes.addTextbox _
(Orientation:=msoTextOrientationHorizontal, _
Left:=400, Top:=100, Width:=250, Height:=60)
With objShape2
.RelativeHorizontalPosition = wdRelativeHorizontalPositionColumn
.RelativeVerticalPosition = wdRelativeVerticalPositionMargin
.Left = wdShapeRight
.Top = wdShapeTop
.TextFrame.TextRange = "This is nice and shine" & vbCrLf & "222"
.TextFrame.TextRange.ParagraphFormat.Alignment = wdAlignParagraphLeft
End With
End With
With .Selection
.TypeParagraph
.TypeParagraph
.TypeParagraph
.TypeParagraph
.TypeParagraph
.TypeParagraph
.TypeParagraph
For i = 1 To 40
.TypeText i
.TypeParagraph
Next i
End With
End With
Word Shape objects must be anchored to a character position in the Word document. They will always appear on the page where the anchor character is and, if the anchor formatting is not to the page, they will move relatively on the page with the anchor character.
A special case ensues when a document is "empty" (a lone paragraph), so it helps to make sure the document has more than one character in it. In the code sample below an additional paragraph is inserted before adding the TextBox - to the first paragraph.
I've made some other adjustments to the code:
Added On Error GoTo 0 so that error messages will appear. Otherwise, debugging becomes impossible.
Removed the With for the Word application since it's not necessary when using Word objects
Declared and use a Word Range object for inserting content. As with Excel, it's better to not work with Selection whenever possible.
Used the wrdDoc object you declare and instantiate instead of ActiveDocument.
This code worked fine in my test, but I cannot, of course, repro your entire environment.
Dim wrdDoc As Object
Dim tmpDoc As Object
Dim WDoc As String
Dim myDoc As String
myDoc = "myTest"
WDoc = ThisDocument.Path & "\mydocument.docx"
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
On Error GoTo 0
If wdApp Is Nothing Then
' no current word application
Set wdApp = CreateObject("Word.application")
Set wrdDoc = wdApp.Documents.Open(WDoc)
wdApp.Visible = True
Else
' word app running
For Each tmpDoc In wdApp.Documents
If StrComp(tmpDoc.FullName, WDoc, vbTextCompare) = 0 Then
' this is your doc
Set wrdDoc = tmpDoc
Exit For
End If
Next
If wrdDoc Is Nothing Then
' not open
Set wrdDoc = wdApp.Documents.Open(WDoc)
End If
End If
wdApp.Visible = True
wrdApp.Activate
Dim i As Long
Dim objShape2 As Word.Shape
Dim rng As Word.Range
Set rng = wrdDoc.Content
rng.Delete
With rng
.InsertAfter vbCr
.Collapse wdCollapseStart
Set objShape2 = ActiveDocument.Shapes.AddTextbox _
(Orientation:=msoTextOrientationHorizontal, _
Left:=400, Top:=100, Width:=250, Height:=60, Anchor:=rng)
With objShape2
.RelativeHorizontalPosition = wdRelativeHorizontalPositionColumn
.RelativeVerticalPosition = wdRelativeVerticalPositionMargin
.Left = wdShapeRight
.Top = wdShapeTop
.TextFrame.TextRange = "This is nice and shine" & vbCrLf & "222"
.TextFrame.TextRange.ParagraphFormat.Alignment = wdAlignParagraphLeft
End With
rng.Start = ActiveDocument.Content.End
For i = 1 To 40
.Text = i & vbCr
.Collapse wdCollapseEnd
Next i
End With
Another solution for you to look at.
'12345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789
'========1=========2=========3=========4=========5=========6=========7=========8=========9=========A=========B=========C
Option Explicit
Sub textboxtest()
Const my_doc_name As String = "mydocument.docx"
Dim my_fso As Scripting.FileSystemObject
Dim my_doc As Word.Document
Dim my_range As Word.Range
Dim counter As Long
Dim my_text_box As Word.Shape
Dim my_shape_range As Word.ShapeRange
' There is no need to test for the Word app existing
' if this macro is in a Word template or Document
' because to run the macro Word MUST be loaded
Set my_fso = New Scripting.FileSystemObject
If my_fso.FileExists(ThisDocument.Path & "\" & my_doc_name) Then
Set my_doc = Documents.Open(ThisDocument.Path & "\" & my_doc_name)
Else
Set my_doc = Documents.Add
my_doc.SaveAs2 ThisDocument.Path & "\" & my_doc_name
End If
my_doc.Activate ' Although it should already be visible
my_doc.content.Delete
Set my_text_box = my_doc.Shapes.AddTextbox( _
Orientation:=msoTextOrientationHorizontal, _
left:=400, _
top:=100, _
Width:=250, _
Height:=60)
With my_text_box
.Name = "TextBox1"
.RelativeHorizontalPosition = wdRelativeHorizontalPositionColumn
.RelativeVerticalPosition = wdRelativeVerticalPositionMargin
.left = wdShapeRight
.top = wdShapeTop
With .TextFrame
.TextRange = "This is nice and shine" & vbCrLf & "222"
.TextRange.ParagraphFormat.Alignment = wdAlignParagraphLeft
End With
End With
Set my_range = my_text_box.Parent.Paragraphs(1).Range
'FROM
'
' https://learn.microsoft.com/en-us/office/vba/api/word.shape'
' Every Shape object is anchored to a range of text. A shape is anchored
' to the beginning of the first paragraph that contains the anchoring
' range. The shape will always remain on the same page as its anchor.
my_range.Collapse Direction:=wdCollapseEnd
With my_range
For counter = 1 To 90
.Text = counter
.InsertParagraphAfter
.Collapse Direction:=wdCollapseEnd
Next
End With
End Sub

transfer data from word to excel via vba

I have a form in ms word with some of the fields are content control and some (which are the radio buttons) are ActiveX control. I want to automatically transfer hundred word forms to an excel file. I use the following vba code:
Sub getWordFormData()
Dim wdApp As New Word.Application
Dim myDoc As Word.Document
Dim CCtl As Word.ContentControl
Dim myFolder As String, strFile As String
Dim myWkSht As Worksheet, i As Long, j As Long
myFolder = "C:\Users\alarfajal\Desktop\myform"
Application.ScreenUpdating = False
If myFolder = "" Then Exit Sub
Set myWkSht = ActiveSheet
ActiveSheet.Cells.Clear
Range("A1") = "name"
Range("a1").Font.Bold = True
Range("B1") = "age"
Range("B1").Font.Bold = True
Range("C1") = "gender"
Range("C1").Font.Bold = True
Range("D1") = "checkbox1"
Range("D1").Font.Bold = True
Range("E1") = "checkbox2"
Range("E1").Font.Bold = True
Range("F1") = "singlechoice1"
Range("F1").Font.Bold = True
Range("G1") = "singlechoice2"
Range("G1").Font.Bold = True
i = myWkSht.Cells(myWkSht.Rows.Count, 1).End(xlUp).Row
strFile = Dir(myFolder & "\*.docx", vbNormal)
While strFile <> ""
i = i + 1
Set myDoc = wdApp.Documents.Open(Filename:=myFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
With myDoc
j = 0
For Each CCtl In .ContentControls
j = j + 1
myWkSht.Cells(i, j) = CCtl.Range.Text
Next
myWkSht.Columns.AutoFit
End With
myDoc.Close SaveChanges:=False
strFile = Dir()
Wend
wdApp.Quit
Set myDoc = Nothing: Set wdApp = Nothing: Set myWkSht = Nothing
Application.ScreenUpdating = True
End Sub
all the data (text fields, checkbox) are transferred successfully but, the radio button (which is ActiveX) is not transferred.
This is the word doc:
This is the excel result:
How can I solve this problem?
You can refer to an ActiveX control on a Word document by it's name
myDoc.singlechoice1.Value
It is better to refer to the ContentControls by their tag names.
myDoc.SelectContentControlsByTag("name").Item(1).Range.Text
Refactored Code
Sub getWordFormData()
Dim wdApp As Object, myDoc As Object
Dim myFolder As String, strFile As String
Dim i As Long, j As Long
myFolder = "C:\Users\alarfajal\Desktop\myform"
If Len(Dir(myFolder)) = 0 Then
MsgBox myFolder & vbCrLf & "Not Found", vbInformation, "Cancelled - getWordFormData"
Exit Sub
End If
Application.ScreenUpdating = False
Set wdApp = CreateObject("Word.Application")
With ActiveSheet
.Cells.Clear
With .Range("A1:G1")
.Value = Array("name", "age", "gender", "checkbox1", "checkbox2", "singlechoice1", "singlechoice2")
.Font.Bold = True
End With
strFile = Dir(myFolder & "\*.docx", vbNormal)
i = 1
While strFile <> ""
i = i + 1
Set myDoc = wdApp.Documents.Open(Filename:=myFolder & "\" & strFile, ReadOnly:=True, AddToRecentFiles:=False, Visible:=False)
.Cells(i, 1).Value = myDoc.SelectContentControlsByTag("name").Item(1).Range.Text
.Cells(i, 2).Value = myDoc.SelectContentControlsByTag("age").Item(1).Range.Text
.Cells(i, 3).Value = myDoc.SelectContentControlsByTag("gender").Item(1).Range.Text
.Cells(i, 4).Value = myDoc.SelectContentControlsByTag("checkbox1").Item(1).Checked
.Cells(i, 5).Value = myDoc.SelectContentControlsByTag("checkbox2").Item(1).Checked
.Cells(i, 6).Value = myDoc.singlechoice1.Value
.Cells(i, 7).Value = myDoc.singlechoice2.Value
myDoc.Close SaveChanges:=False
strFile = Dir()
Wend
wdApp.Quit
Application.ScreenUpdating = True
End With
End Sub
Your radiobuttons are inlineshapes so you need a separate loop for them
to keep in line with your current code, it would be something like
Dim shp As InlineShape
For Each shp In .InlineShapes
j = j + 1
myWkSht.Cells(i, j) = shp.OLEFormat.Object.Value
Next shp
However I wouldn't want to rely on Word always giving me the right order and there could be other inlineshapes so it might be better to check the controls first:
With myDoc
'content controls
For Each CCtl In .ContentControls
Select Case CCtl.Title
Case "name"
myWkSht.Cells(i, 1) = CCtl.Range.Text
'similar for age and gender
Case "checkbox1"
myWkSht.Cells(i, 4) = CCtl.Checked 'true and false are easier to evaluate in Excel than the checkmark symbols
'same for checkbox 2
End Select
Next CCtl
'option buttons
For Each shp In .InlineShapes
If shp.Type = wdInlineShapeOLEControlObject Then 'skip other inlineshapes
Select Case shp.OLEFormat.Object.Name
Case "singleSelectQuestionOption1" 'name it something unique
myWkSht.Cells(i, 6) = shp.OLEFormat.Object.Value
'similar for option button 2
End Select
End If
Next shp
End With

Runtime error 462 Excel VBA using Word

I keep getting the 462 error the second or third time I run this loop. I don't think I have any objects that are floating but maybe I missed something, I am kind of new at this. This macro is taking all the charts from Excel, pasting them into Word as pictures, resizing them, saving the document and closing it. The For loop has formatting for the chart to be pasted as a normal picture and the text below it to be caption so I can create a figure table easily.
The error takes place in the .Height = InchesToPoints(6.1) line.
Private Sub ChartstoWord_Click()
Dim WDApp As Word.Application
Dim WDDoc As Word.Document
Dim cname, wordname, restage, pNumber, wfile As String
Dim n As Integer
Dim i As Long
Application.ScreenUpdating = False
If wordfile.Value = "" Then
MsgBox "Please enter a word file name", vbOKOnly
Exit Sub
End If
wfile = CurveDirectoryBox & "\" & wordfile.Value & ".docx"
wordname = UCase(dataname.Value)
'if word file doesn't exist then it makes the word file for you
If Dir(wfile) = "" Then
Set WDApp = CreateObject("Word.application")
WDApp.Visible = True
Set WDDoc = WDApp.Documents.Add
WDApp.Visible = True
With WDDoc
.SaveAs wfile
.Close
End With
Set WDDoc = Nothing
WDApp.Quit
Set WDApp = Nothing
End If
' Create new instance of Word and open filename provided if file exists
Set WDApp = CreateObject("Word.application")
WDApp.Visible = True
WDApp.Documents.Open wfile
WDApp.Visible = True
Set WDDoc = WDApp.ActiveDocument
With WDDoc
.Range(start:=.Range.End - 1, End:=.Range.End - 1).Select
.PageSetup.Orientation = wdOrientLandscape
End With
For n = 1 To Charts.Count
Charts(n).Select
cname = ActiveChart.ChartTitle.Characters.Text
ActiveChart.CopyPicture _
Appearance:=xlScreen, Format:=xlPicture
' Paste chart at end of current document
WDApp.Visible = True
With WDApp
.Selection.Style = WDApp.ActiveDocument.Styles("Normal")
.Selection.Font.Size = 12
.Selection.Font.Bold = True
.Selection.PasteSpecial Link:=False, Placement:=wdInLine, DisplayAsIcon:=False, DataType:=wdPasteEnhancedMetafile
.Selection.TypeParagraph
.Selection.Style = WDApp.ActiveDocument.Styles("Caption")
.Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
.Selection.Font.Size = 12
.Selection.Font.Bold = False
.Selection.TypeText (wordname + " " + cname)
.Selection.TypeParagraph
End With
Next n
'resize all pictures
WDApp.Visible = True
With WDApp
With WDDoc
For i = 1 To WDApp.ActiveDocument.InlineShapes.Count
With WDApp.ActiveDocument.InlineShapes(i)
'.Width = InchesToPoints(7.9)
.Height = InchesToPoints(6.1)
End With
Next i
End With
End With
WDDoc.Save
WDDoc.Close
Set WDDoc = Nothing
WDApp.Quit
Set WDApp = Nothing
Worksheets("Control").Activate
Range("A1").Select
Application.ScreenUpdating = True
End Sub
I was able to solve the problem, ended up being that the command InchesToPoints is a word command and needs the wdapp in front of it. Thanks for all the suggestions, I also cleaned up a code a bit after all your receommendations.
Private Sub ChartstoWord_Click()
Dim WDApp As Word.Application
Dim cname, wordname, restage, pNumber, wfile As String
Dim n As Integer
Dim i, h As Long
Application.ScreenUpdating = False
If wordfile.Value = "" Then
MsgBox "Please enter a word file name", vbOKOnly
Exit Sub
End If
wfile = CurveDirectoryBox & "\" & wordfile.Value & ".docx"
wordname = UCase(dataname.Value)
'if word file doesn't exist then it makes the word file for you
If Dir(wfile) = "" Then
Set WDApp = CreateObject("Word.application")
WDApp.Visible = True
WDApp.Documents.Add
WDApp.ActiveDocument.SaveAs wfile
WDApp.ActiveDocument.Close
WDApp.Quit
Set WDApp = Nothing
End If
' Create new instance of Word and open filename provided if file exists, checks to see if file is open or not already
If IsFileOpen(wfile) = False Then
Set WDApp = CreateObject("Word.application")
WDApp.Visible = True
WDApp.Documents.Open wfile
End If
If IsFileOpen(wfile) = True Then
Set WDApp = GetObject(wfile).Application
WDApp.Visible = True
End If
'moves cursor in word to the end of the document and change page to landscape
WDApp.ActiveDocument.Range(start:=WDApp.ActiveDocument.Range.End - 1, End:=WDApp.ActiveDocument.Range.End - 1).Select
WDApp.ActiveDocument.PageSetup.Orientation = wdOrientLandscape
'loops through all charts and pastes them in word
For n = 1 To Charts.Count
Charts(n).Select
cname = ActiveChart.ChartTitle.Characters.Text
ActiveChart.CopyPicture Appearance:=xlScreen, Format:=xlPicture
WDApp.Visible = True
WDApp.Selection.Style = WDApp.ActiveDocument.Styles("Normal")
WDApp.Selection.Font.Size = 12
WDApp.Selection.Font.Bold = True
WDApp.Selection.PasteSpecial Link:=False, Placement:=wdInLine, DisplayAsIcon:=False, DataType:=wdPasteEnhancedMetafile
WDApp.Selection.TypeParagraph
WDApp.Selection.Style = WDApp.ActiveDocument.Styles("Caption")
WDApp.Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
WDApp.Selection.Font.Size = 12
WDApp.Selection.Font.Bold = False
WDApp.Selection.TypeText (wordname + " " + cname)
WDApp.Selection.TypeParagraph
Next n
'resize all pictures
WDApp.Visible = True
For i = 1 To WDApp.ActiveDocument.InlineShapes.Count
WDApp.ActiveDocument.InlineShapes(i).Select
WDApp.ActiveDocument.InlineShapes(i).Height = WDApp.InchesToPoints(6.1)
Next i
WDApp.ActiveDocument.SaveAs wfile
WDApp.ActiveDocument.Close
WDApp.Quit
Set WDApp = Nothing
Worksheets("Control").Activate
Range("A1").Select
Application.ScreenUpdating = True
End Sub
Definitly too much With, and not even used, so here is a version of your resize that should be cleaner but not sure that it'll be enough, give it a try
Too many WDApp.Visible = True also, only one will be enough but as you close it after, you should even set it to False!
'resize all pictures
For i = 1 To WDDoc.InlineShapes.Count
With WDDoc.InlineShapes(i)
'.Width = InchesToPoints(7.9)
.Height = InchesToPoints(6.1)
End With
Next i

Automatic Excel Acronym finding and Definition adding

I regularly have to create documents at work and within the company we almost have a language of our own due to the number of acronyms and abbreviations we use. Consequently I got tired of manually creating an Acronym and abbreviation table before I could publish the document and a quick google search came across a macro that would effectively do it for me. (modified code shown below)
I modified this macro so that the table was pasted into the location of the cursor in the original document (this may not be the msot efficient way, but it was the simplest i could think of as I am not a VBA expert).
Since then I have realised that there must be a simple way to further speed up this process by automatically including the definitions as well. I have an excel spreadsheet with the Acronym in the first column and its definition in the second.
So far I have been able to get as far as opening the excel document but cannot seem to get a search which will return the row number and consequently use this to copy the contents of the definition cell next to it into the corresponding definition section of the table in Word.
** edit - extra explanation **
The current macro searches the word document and finds all the acronyms that have been used and places them in a table in a seperate word document. What i wish to do is have it also then search an excel file (pre-existing) for the definition of each of the found acronyms and add them also to the table or if they are new leave it blank. Finally the macro copies this table back into the original document.
This code currently fails saying the .Find function is not defined? (I have kept the code seperate for now to keep testing simple)
Dim objExcel As Object
Dim objWbk As Object
Dim objDoc As Document
Dim rngSearch As Range
Dim rngFound As Range
Set objDoc = ActiveDocument
Set objExcel = CreateObject("Excel.Application")
Set objWbk = objExcel.Workbooks.Open("P:\ENGINEERING\EL\Global Access\Abbreviations and Acronyms.xls")
objExcel.Visible = True
objWbk.Activate
With objExcel
With objWbk
Set rngSearch = objWbk.Range("A:A")
Set rngFound = rngSearch.Find(What:="AS345", LookIn:=xlValues, LookAt:=xlPart)
If rngFound Is Nothing Then
MsgBox "Not found"
Else
MsgBox rngFound.Row
End If
End With
End With
Err_Exit:
'clean up
Set BMRange = Nothing
Set objWbk = Nothing
objExcel.Visible = True
Set objExcel = Nothing
Set objDoc = Nothing
'MsgBox "The document has been updated"
Err_Handle:
If Err.Number = 429 Then 'excel not running; launch Excel
Set objExcel = CreateObject("Excel.Application")
Resume Next
ElseIf Err.Number <> 0 Then
MsgBox "Error " & Err.Number & ": " & Err.Description
Resume Err_Exit
End If
End Sub
Acronym extraction code
Sub ExtractACRONYMSToNewDocument()
'=========================
'Macro created 2008 by Lene Fredborg, DocTools - www.thedoctools.com
'THIS MACRO IS COPYRIGHT. YOU ARE WELCOME TO USE THE MACRO BUT YOU MUST KEEP THE LINE ABOVE.
'YOU ARE NOT ALLOWED TO PUBLISH THE MACRO AS YOUR OWN, IN WHOLE OR IN PART.
'=========================
'Modified in 2014 by David Mason to place the acronym table in the original document
'=========================
Dim oDoc_Source As Document
Dim oDoc_Target As Document
Dim strListSep As String
Dim strAcronym As String
Dim strDef As String
Dim oTable As Table
Dim oRange As Range
Dim n As Long
Dim strAllFound As String
Dim Title As String
Dim Msg As String
Title = "Extract Acronyms to New Document"
'Show msg - stop if user does not click Yes
Msg = "This macro finds all words consisting of 3 or more " & _
"uppercase letters and extracts the words to a table " & _
"in a new document where you can add definitions." & vbCr & vbCr & _
"Do you want to continue?"
If MsgBox(Msg, vbYesNo + vbQuestion, Title) <> vbYes Then
Exit Sub
End If
Application.ScreenUpdating = False
'Find the list separator from international settings
'May be a comma or semicolon depending on the country
strListSep = Application.International(wdListSeparator)
'Start a string to be used for storing names of acronyms found
strAllFound = "#"
Set oDoc_Source = ActiveDocument
'Create new document for acronyms
Set oDoc_Target = Documents.Add
With oDoc_Target
'Make sure document is empty
.Range = ""
'Insert info in header - change date format as you wish
'.PageSetup.TopMargin = CentimetersToPoints(3)
'.Sections(1).Headers(wdHeaderFooterPrimary).Range.Text = _
' "Acronyms extracted from: " & oDoc_Source.FullName & vbCr & _
' "Created by: " & Application.UserName & vbCr & _
' "Creation date: " & Format(Date, "MMMM d, yyyy")
'Adjust the Normal style and Header style
With .Styles(wdStyleNormal)
.Font.Name = "Arial"
.Font.Size = 10
.ParagraphFormat.LeftIndent = 0
.ParagraphFormat.SpaceAfter = 6
End With
With .Styles(wdStyleHeader)
.Font.Size = 8
.ParagraphFormat.SpaceAfter = 0
End With
'Insert a table with room for acronym and definition
Set oTable = .Tables.Add(Range:=.Range, NumRows:=2, NumColumns:=2)
With oTable
'Format the table a bit
'Insert headings
.Range.Style = wdStyleNormal
.AllowAutoFit = False
.Cell(1, 1).Range.Text = "Acronym"
.Cell(1, 2).Range.Text = "Definition"
'.Cell(1, 3).Range.Text = "Page"
'Set row as heading row
.Rows(1).HeadingFormat = True
.Rows(1).Range.Font.Bold = True
.PreferredWidthType = wdPreferredWidthPercent
.Columns(1).PreferredWidth = 20
.Columns(2).PreferredWidth = 70
'.Columns(3).PreferredWidth = 10
End With
End With
With oDoc_Source
Set oRange = .Range
n = 1 'used to count below
With oRange.Find
'Use wildcard search to find strings consisting of 3 or more uppercase letters
'Set the search conditions
'NOTE: If you want to find acronyms with e.g. 2 or more letters,
'change 3 to 2 in the line below
.Text = "<[A-Z]{3" & strListSep & "}>"
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = True
.MatchWildcards = True
'Perform the search
Do While .Execute
'Continue while found
strAcronym = oRange
'Insert in target doc
'If strAcronym is already in strAllFound, do not add again
If InStr(1, strAllFound, "#" & strAcronym & "#") = 0 Then
'Add new row in table from second acronym
If n > 1 Then oTable.Rows.Add
'Was not found before
strAllFound = strAllFound & strAcronym & "#"
'Insert in column 1 in oTable
'Compensate for heading row
With oTable
.Cell(n + 1, 1).Range.Text = strAcronym
'Insert page number in column 3
'.Cell(n + 1, 3).Range.Text = oRange.Information(wdActiveEndPageNumber)
End With
n = n + 1
End If
Loop
End With
End With
'Sort the acronyms alphabetically - skip if only 1 found
If n > 2 Then
With Selection
.Sort ExcludeHeader:=True, FieldNumber:="Column 1", SortFieldType _
:=wdSortFieldAlphanumeric, SortOrder:=wdSortOrderAscending
'Go to start of document
.HomeKey (wdStory)
End With
End If
'Copy the whole table, switch to the source document and past
'in the table at the original selection location
Selection.WholeStory
Selection.Copy
oDoc_Source.Activate
Selection.Paste
'make the target document active and close it down without saving
oDoc_Target.Activate
ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
Application.ScreenUpdating = True
'If no acronyms found, show msg and close new document without saving
'Else keep open
If n = 1 Then
Msg = "No acronyms found."
oDoc_Target.Close SaveChanges:=wdDoNotSaveChanges
Else
Msg = "Finished extracting " & n - 1 & " acronymn(s) to a new document."
End If
MsgBox Msg, vbOKOnly, Title
'Clean up
Set oRange = Nothing
Set oDoc_Source = Nothing
Set oDoc_Target = Nothing
Set oTable = Nothing
End Sub
You are just missing the Worksheet Object.
Also With objExcel can be ommited since you already pass the Workbook Object to objWbk variable.
With objWbk.Sheets("NameOfYourSheet")
Set rngSearch = .Range(.Range("A1"), .Range("A" & .Rows.Count).End(xlUp))
Set rngFound = rngSearch.Find(What:="AS345", After:=.Range("A1"), LookAt:=xlWhole)
If rngFound Is Nothing Then
MsgBox "Not found"
Else
MsgBox rngFound.Row
End If
End With
In the above code, I assumed your Excel data have headers.
Edit1: Since you are Late Binding Excel, this should work:
With objWbk.Sheets("Sheet1")
Set rngSearch = .Range(.Range("A1"), .Range("A" & .Rows.Count).End(-4162))
Set rngFound = rngSearch.Find(What:="AS345", After:=.Range("A1"), LookAt:=1)
If rngFound Is Nothing Then
MsgBox "Not found"
Else
MsgBox rngFound.Row
End If
End With
Take note that we replaced xlUp with it's equivalent constant -4162 and xlWhole with 1.
To learn more about Early and Late Binding, check THIS out.
For additional information, you can also refer HERE.
Although it is dicussed in the link I provided, you might ask where do I get the constant?
Just open Excel or any other MS application you are binding then view Immediate Window - Ctrl+G
In the immediate window, type ? then the constant you want to get the numeric equivalent.
Example:
?xlUp
-4162
?xlWhole
1
?xlPart
2
Hope this somehow solves your problem.
So it would appear with some searching I found the solution to the problem. A big thank you to L42 who helped solve the problem regarding whether i was using Early or Late binding (I had no idea these were even different).
The remaining problem where the following error occured:
Compile Error: Named Argument not found
Was suprisingly easy to solve once I found the solution... you have to love hindsight. It turns out I had to define my two variables rngFound and rngSearch as objects. As soon as i made that change the code worked beautifully.
Here is the working code which I will then incorporate into my acronym macro. (will add the total code when complete)
Sub openExcel()
Dim objExcel As Object
Dim objWbk As Object
Dim objDoc As Document
Dim rngSearch As Object
Dim rngFound As Object
Dim targetCellValue
Set objDoc = ActiveDocument
Set objExcel = CreateObject("Excel.Application")
Set objWbk = objExcel.Workbooks.Open("C:\Users\DMASON2\Documents\Book1.xlsx")
objExcel.Visible = True
objWbk.Activate
With objWbk.Sheets("Sheet1")
Set rngSearch = .Range(.Range("A1"), .Range("A" & .Rows.Count).End(-4162))
Set rngFound = rngSearch.Find(What:="AA", After:=.Range("A1"), LookAt:=1)
If rngFound Is Nothing Then
MsgBox "Not found"
Else
'MsgBox rngFound.Row
targetCellValue = .Cells(rngFound.Row, 2).Value
MsgBox (targetCellValue)
End If
End With
Err_Exit:
'clean up
Set BMRange = Nothing
Set objWbk = Nothing
objExcel.Visible = True
Set objExcel = Nothing
Set objDoc = Nothing
'MsgBox "The document has been updated"
Err_Handle:
If Err.Number = 429 Then 'excel not running; launch Excel
Set objExcel = CreateObject("Excel.Application")
Resume Next
ElseIf Err.Number <> 0 Then
MsgBox "Error " & Err.Number & ": " & Err.Description
Resume Err_Exit
End If
End Sub
** edit, complete code for searching and finding the acronyms along with their definitions **
Sub ExtractACRONYMSToNewDocument()
Dim oDoc_Source As Document
Dim oDoc_Target As Document
Dim strListSep As String
Dim strAcronym As String
Dim strDef As String
Dim oTable As Table
Dim oRange As Range
Dim n As Long
Dim m As Long
m = 0
Dim strAllFound As String
Dim Title As String
Dim Msg As String
Dim objExcel As Object
Dim objWbk As Object
Dim rngSearch As Object
Dim rngFound As Object
Dim targetCellValue As String
' message box title
Title = "Extract Acronyms to New Document"
' Set message box message
Msg = "This macro finds all Acronyms (consisting of 2 or more " & _
"uppercase letters, Numbers or '/') and their associated definitions. It " & _
"then extracts the words to a table at the current location you have selected" & vbCr & vbCr & _
"Warning - Please make sure you check the table manually after!" & vbCr & vbCr & _
"Do you want to continue?"
' Display message box
If MsgBox(Msg, vbYesNo + vbQuestion, Title) <> vbYes Then
Exit Sub
End If
' Stop the screen from updating
Application.ScreenUpdating = False
'Find the list separator from international settings
'May be a comma or semicolon depending on the country
strListSep = Application.International(wdListSeparator)
'Start a string to be used for storing names of acronyms found
strAllFound = "#"
' give the active document a variable
Set oDoc_Source = ActiveDocument
'Crete a variable for excel and open the definition workbook
Set objExcel = CreateObject("Excel.Application")
Set objWbk = objExcel.Workbooks.Open("C:\Users\Dave\Documents\Test_Definitions.xlsx")
'objExcel.Visible = True
objWbk.Activate
'Create new document to temporarily store the acronyms
Set oDoc_Target = Documents.Add
' Use the target document
With oDoc_Target
'Make sure document is empty
.Range = ""
'Insert info in header - change date format as you wish
'.PageSetup.TopMargin = CentimetersToPoints(3)
'.Sections(1).Headers(wdHeaderFooterPrimary).Range.Text = _
' "Acronyms extracted from: " & oDoc_Source.FullName & vbCr & _
' "Created by: " & Application.UserName & vbCr & _
' "Creation date: " & Format(Date, "MMMM d, yyyy")
'Adjust the Normal style and Header style
With .Styles(wdStyleNormal)
.Font.Name = "Arial"
.Font.Size = 10
.ParagraphFormat.LeftIndent = 0
.ParagraphFormat.SpaceAfter = 6
End With
With .Styles(wdStyleHeader)
.Font.Size = 8
.ParagraphFormat.SpaceAfter = 0
End With
'Insert a table with room for acronym and definition
Set oTable = .Tables.Add(Range:=.Range, NumRows:=2, NumColumns:=2)
With oTable
'Format the table a bit
'Insert headings
.Range.Style = wdStyleNormal
.AllowAutoFit = False
.Cell(1, 1).Range.Text = "Acronym"
.Cell(1, 2).Range.Text = "Definition"
'Set row as heading row
.Rows(1).HeadingFormat = True
.Rows(1).Range.Font.Bold = True
.PreferredWidthType = wdPreferredWidthPercent
.Columns(1).PreferredWidth = 20
.Columns(2).PreferredWidth = 70
End With
End With
With oDoc_Source
Set oRange = .Range
n = 1 'used to count below
' within the total range of the source document
With oRange.Find
'Use wildcard search to find strings consisting of 3 or more uppercase letters
'Set the search conditions
'NOTE: If you want to find acronyms with e.g. 2 or more letters,
'change 3 to 2 in the line below
.Text = "<[A-Z][A-Z0-9/]{1" & strListSep & "}>"
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = True
.MatchWildcards = True
'Perform the search
Do While .Execute
'Continue while found
strAcronym = oRange
'Insert in target doc
'If strAcronym is already in strAllFound, do not add again
If InStr(1, strAllFound, "#" & strAcronym & "#") = 0 Then
'Add new row in table from second acronym
If n > 1 Then oTable.Rows.Add
'Was not found before
strAllFound = strAllFound & strAcronym & "#"
'Insert in column 1 in oTable
'Compensate for heading row
With oTable
.Cell(n + 1, 1).Range.Text = strAcronym
' Find the definition from the Excel document
With objWbk.Sheets("Sheet1")
' Find the range of the cells with data in Excel doc
Set rngSearch = .Range(.Range("A1"), .Range("A" & .Rows.Count).End(-4162))
' Search in the found range for the
Set rngFound = rngSearch.Find(What:=strAcronym, After:=.Range("A1"), LookAt:=1)
' if nothing is found count the number of acronyms without definitions
If rngFound Is Nothing Then
m = m + 1
' Set the cell variable in the new table as blank
targetCellValue = ""
' If a definition is found enter it into the cell variable
Else
targetCellValue = .Cells(rngFound.Row, 2).Value
End If
End With
' enter the cell varibale into the definition cell
.Cell(n + 1, 2).Range.Text = targetCellValue
End With
' add one to the loop count
n = n + 1
End If
Loop
End With
End With
'Sort the acronyms alphabetically - skip if only 1 found
If n > 2 Then
With Selection
.Sort ExcludeHeader:=True, FieldNumber:="Column 1", SortFieldType _
:=wdSortFieldAlphanumeric, SortOrder:=wdSortOrderAscending
'Go to start of document
.HomeKey (wdStory)
End With
End If
'Copy the whole table, switch to the source document and past
'in the table at the original selection location
Selection.WholeStory
Selection.Copy
oDoc_Source.Activate
Selection.Paste
' update screen
Application.ScreenUpdating = True
'If no acronyms found set message saying so
If n = 1 Then
Msg = "No acronyms found."
' set the final messagebox message to show the number of acronyms found and those that did not have definitions
Else
Msg = "Finished extracting " & n - 1 & " acronymn(s) to a new document. Unable to find definitions for " & m & " acronyms."
End If
' Show the finished message box
AppActivate Application.Caption
MsgBox Msg, vbOKOnly, Title
'make the target document active and close it down without saving
oDoc_Target.Activate
ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
'Close Excel after
objWbk.Close Saved = True
'Clean up
Set oRange = Nothing
Set oDoc_Source = Nothing
Set oDoc_Target = Nothing
Set oTable = Nothing
Set objExcel = Nothing
Set objWbk = Nothing
End Sub