I am enumerating tables in Microsoft Word in a following way:
Dim doc As Document, t As Table
Set doc = ActiveDocument
For Each t In doc.Tables
Next t
Now I would like to find the nearest paragraph with "Heading 2" style above the table and get it's text into a variable. Great if it could be accomplished without changing the selection focus in the document.
I can enumerate paragraphs in the document, but how to determine that some paragraph is above some table?
I solved that by building a list of paragraph start positions:
Private Type CaptionRec
Text As String
EndPos As Long
End Type
Dim caps() As CaptionRec
Dim i As Long
Dim p As Paragraph
ReDim caps(0)
i = 0
For Each p In doc.Paragraphs
If p.Style = "Überschrift 2" Then
i = i + 1
ReDim Preserve caps(i)
caps(i).Text = TrimGarbageAtEnd(p.Range.Text)
caps(i).EndPos = p.Range.Start 'Ok, this should be the end, not the start
End If
Next p
... and finding the minimum distance between table start and a "Heading 2" paragraph from array:
Public Function GetClosestCaption(tableStart As Long, ByRef caps() As CaptionRec) As String
Dim cap As CaptionRec, distance As Long, minDistance As Long, res As String, i As Long
minDistance = 2147483647 'Max long
res = ""
For i = LBound(caps) To UBound(caps)
cap = caps(i)
distance = tableStart - cap.EndPos
If distance >= 0 Then
If distance < minDistance Then
minDistance = distance
res = cap.Text
End If
End If
Next i
GetClosestCaption = res
End Function
The routine gets called in a following loop:
Public Sub MainRoutine()
For Each t In doc.Tables
If table_validity_criteria_go_here Then
caption = GetClosestCaption(t.Range.Start, caps)
For Each r In t.Rows
'Enumerate rows
Next r
End If
Next t
End Sub
An alternative is to reverse the logic. Instead of processing the tables and then looking for the associated heading, find the headings then process the tables within the range of the heading level, For example:
Sub FindHeading2Ranges()
Dim findRange As Range
Dim headingRange As Range
Set findRange = ActiveDocument.Content
With findRange.Find
.ClearFormatting
.Forward = True
.Wrap = wdFindStop
.Format = True
.Style = ActiveDocument.Styles(wdStyleHeading2)
Do While .Execute
Set headingRange = findRange.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
If headingRange.Tables.Count > 0 Then
ProcessTables headingRange, TrimGarbageAtEnd(findRange.text)
End If
findRange.Collapse wdCollapseEnd
Loop
End With
End Sub
Sub ProcessTables(headingRange As Range, caption As String)
Dim t As Table
For Each t In headingRange.Tables
If table_validity_criteria_go_here Then
For Each r In t.Rows
'Enumerate rows
Next r
End If
Next t
End Sub
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
The program is supposed to loop through a directory to find every occurrence of a word from a list that is in another word document and expand selection to the whole question. This program is supposed to allow you to compile a list of test questions from a test bank based on a list of highly relevant key terms. Eventually, once all the relevant questions are selected They would be copied to a new document.
Sub CompareWordList()
'program to loop through Directory to find every occurrence of a word from a list and expand selection to
'the whole question. This program is supposed to allow you to compile a list of test questions from a
'test bank based on a list of highly relevent key terms. Eventually, once all the relevent questions are selected
'They would be copied to a new document
'variables for directory looping
Dim vDirectory As String
Dim oDoc As Document
'generates file path
vDirectory = "D:\school\documents\MGT450\Test_Bank\TB - test\" 'set directory to loop through
vFile = Dir(vDirectory & "*.*") 'file name
'variables for selection
Dim sCheckDoc As String
Dim docRef As Document
'Dim docCurrent As Document
Dim wrdRef As Object
'list of words to look for
sCheckDoc = "D:\testlist.docx"
Set docRef = Documents.Open(sCheckDoc)
'docCurrent.Activate
docRef.Activate
'Directory Loop
Do While vFile <> ""
Set oDoc = Documents.Open(FileName:=vDirectory & vFile)
'document activation
oDoc.Activate
SendDocToArray_FindWords (sCheckDoc)
'Havent really worked on this area yet, as been focused on find issue
docRef.Close
'close document modification
oDoc.Close SaveChanges:=False
vFile = Dir
Loop
End Sub
'After every instance of a particular phrase is selected, select question
around said phrase
Function SelectQuestion(Index As Long)
'iniitial declaration
Dim linecount As Integer
Set mydoc = ActiveDocument
Dim oPara As word.Paragraph
'Dim oPara As selection
Dim ListLevelNumber As Integer
Dim holder As Long
'if list type is simple numbering
If selection.Range.ListFormat.ListType = wdListSimpleNumbering Or
wdListBullet Or wdListMixedNumbering Then
'Select Whole Question containing word
With selection
.StartIsActive = False
.Extend Character:=";"
.EndKey
.StartOf (wdLine)
End With
a = selection.MoveUntil(";", wdBackward)
b = selection.MoveDown(wdLine, 2, wdMove)
selection.StartOf (wdLine)
selection.Find.Execute "*^13^13", , , True
'some correction of range- remove last paragraph from selection
ActiveDocument.Range(selection.Start, selection.End - 1).Select
End If
End Function
Function GetParNum(r As Range) As Integer
'determines paragraph number
GetParNum = selection.Range.ListFormat.ListValue
End Function
Sub Test() 'testing function
CountWords
End Sub
Function SendDocToArray_FindWords(name As String) As Variant
'sends a document to an array split by newline
'the document that is send to the array is composed of the words that are
'being searched for.
Dim doc As Document
Set doc = Documents.Open(name)
Dim arr() As String
arr() = Split(doc.Content.Text, Chr(13))
Dim iCount As Integer
Dim targetRng As Range
For Each i In arr()
Dim r As Range
Dim j As Long
Set r = ActiveDocument.Content
With r.Find
'If I pass a variable to FindText it only finds the first instance of the word then
'prematurely exits loop or becomes an infinite loop
'strangely the function is only working when I hardcode the word such as
'FindText:= "International Business"
Do While .Execute(FindText:=i, Forward:=True, Wrap:=wdFindContinue) = True
If r.Find.Found = True Then
j = j + 1
End If
Loop
End With
MsgBox "The Word" & i & " was found " & j & " times."
Next i
MsgBox ("Finished Selecting")
End Function
'testing count words function
Function CountWords(c As String) 'ByRef word As Variant
'counts number of occurences of words in document
Dim r As Range
Dim j As Long
Set r = ActiveDocument.Content
'ResetFRParameters r
With r.Find
'.Wrap = wdFindContinue
Do While .Execute(FindText:=i, Forward:=True) = True
If r.Find.Found = True Then
j = j + 1
End If
Loop
End With
MsgBox "Given word(s) was found " & j & " times."
End Function
'testing count words function
Sub FindText()
Dim MyAR() As String
Dim i As Long
i = 0
selection.HomeKey Unit:=wdStory
selection.Find.Text = "International Business"
' selection.Range.Text
Do While selection.Find.Execute = True
ReDim Preserve MyAR(i)
MyAR(i) = selection
i = i + 1
Loop
If i = 0 Then
MsgBox "No Matches Found"
Exit Sub
End If
For i = LBound(MyAR) To UBound(MyAR)
MsgBox ("# of International Business occurrences " & i)
Next i
End Sub
I used three finds that I was trying to get to work correctly but they do not appear to search the whole document regardless how I use them. I have started wondering if the formatting of my document is to blame. I have attached both an image of the list of terms as well as document to search through.
This is the list of terms to search through
This is the document to search through
My ultimate question is how do I get around this problem and find all instances of the given search term in the document? As of now it either finds the first instance and breaks or becomes an infinite loop.
This is the final that works, although not he prettiest, for others who may be looking for similar code: (pasting it here as messed up the format a bit so youll need to fix those if you use it)
Sub TraversePath()
Dim fso As Object 'FileSystemObject
Dim fldStart As Object 'Folder
Dim fld As Object 'Folder
Dim fl As Object 'File
Dim Mask As String '.doc,.docx,.xlsx, etc
Set fso = CreateObject("scripting.FileSystemObject") ' late binding
'Set fso = New FileSystemObject 'or use early binding (also replace Object
types)
Set fldStart = fso.GetFolder("D:\school\documents\MGT450\Test_Bank\TB -
test\") ' Base Directory
Mask = "*.doc"
ListFiles fldStart, Mask
'for each file in folder
'For Each fl In fldStart
' ListFiles fld, Mask
MsgBox ("Fin.")
'Next
End Sub
Sub ListFiles(fld As Object, Mask As String)
Dim runTracker As Integer
runTracker = 0
Dim fl As Object 'File
x = NewDoc 'generate new processed study guide
Dim sCheckDoc As String
Dim docRef As Document
Dim vFile As String
Dim arr() As String
'list of words to look for
sCheckDoc = "D:\testlist.docx"
Set docRef = Documents.Open(sCheckDoc)
docRef.Activate
'send docref to array split by newline
arr() = Split(docRef.Content.Text, Chr(13))
'begin word array loop?
For Each fl In fld.Files
runTracker = runTracker + 1
If fl.name Like Mask Then
'-----------------------------------------------------------------run
program code
vFile = fl.name 'set vFile = current file name
a = Documents.Open(fld.path & "\" & fl.name) 'open current search
file
Documents(vFile).Activate 'activate current search file
For a = 0 To UBound(arr)
'reset selection
selection.HomeKey Unit:=wdStory, Extend:=wdMove
'Inform progress
StatusBar = "Running Find..."
Dim docB As String
docB = Documents("Processed_StudyGuide.docx")
Dim docA As String
docA = Documents(vFile)
Documents(docA).Activate
b = DoFindReplace_Bkmk(arr(a))
'print bookmarked values to new document
StatusBar = "Printing targeted paragraphs..."
PrintBookmarks (bookmarkName)
If b <> 0 Then
'notify how many were inserted
MsgBox ("Complete, inserted: " & b & " bookmarks of " &
arr(a))
End If
Next a
MsgBox ("finished find in: " & vFile)
Documents(vFile).Close (wdDoNotSaveChanges)
'-----------------------------------------------------------------end
code
End If
Next
MsgBox ("Finished all documents")
End Sub
Function SelectQuestion(Index As Long)
'iniitial declaration
Dim linecount As Integer
Dim oPara As word.Paragraph
'Dim oPara As selection
Dim ListLevelNumber As Integer
Dim holder As Long
'if list type is simple numbering
If selection.Range.ListFormat.ListType = wdListSimpleNumbering Or
wdListBullet Or wdListMixedNumbering Then
'Select Whole Question containing word
With selection
.StartIsActive = False
.Extend Character:=";"
.EndKey
.StartOf (wdLine)
End With
a = selection.MoveUntil(";", wdBackward)
b = selection.MoveDown(wdLine, 2, wdMove)
selection.StartOf (wdLine)
selection.Find.Execute "*^13^13", , , True
'some correction of range- remove last paragraph from selection
'ActiveDocument.Range(selection.start, selection.End - 1).Select
End If
End Function
Function GetParNum(r As Range) As Integer
'determines paragraph number
GetParNum = selection.Range.ListFormat.ListValue
End Function
Function NewDoc() As String
'Generate new document and save
a = Documents.Add(, , , True)
ActiveDocument.Content.Delete
ActiveDocument.SaveAs2 ("D:\Processed_StudyGuide")
End Function
Public Function GetName(num As Integer) As String
'names each bookmark
Dim t As String
Dim nameArr() As Variant
nameArr = Array("a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k", "l",
"m", "n", "o", "p", "q", "r", "s", "t", "u", "v", "w", "x", "y", "z", "aa",
"bb", "cc", "dd", "ee", "ff", "gg", "hh", "ii", "jj", "kk", "ll", "mm",
"nn", "oo", "pp", "qq", "rr", "ss", "tt", "uu", "vv", "ww", "xx", "yy",
"zz", "aaa", "bbb", "ccc", "ddd", "eee", "fff", "ggg", "hhh", "iii", "jjj",
"kkk", "lll", "mmm", "nnn", "ooo", "ppp", "qqq", "rrr", "sss", "ttt", "uuu",
"vvv", "www", "xxx", "yyy", "zzz", "aaaa", "bbbb", "cccc", "dddd", "eeee",
"ffff", "gggg", "hhhh", "iiii", "jjjj", "kkkk", "llll", "mmmm", "nnnn",
"oooo", "pppp", "qqqq", "rrrr", "ssss", "tttt", "uuuu", "vvvv", "wwww",
"xxxx", "yyyy", "zzzz", "aaaaa", "bbbbb", "ccccc", "ddddd")
t = nameArr(num)
GetName = t
End Function
Function PrintBookmarks(name As String) 'Add each selection to collection
'Declarations
selection.Collapse
Dim n As Integer
Dim docB As String
docB = Documents("Processed_StudyGuide.docx")
Dim docA As String
docA = ActiveDocument.name
Dim x As Integer
x = ActiveDocument.Bookmarks.Count
Dim a As String
For Each bkmark In Documents(docA).Bookmarks
'If # of bookmarks is greater than 0 select the one at x
If x > 0 Then
With ActiveDocument.Bookmarks(x)
BkMkName = .name
.Select
End With
End If
'selection.Bookmarks(a).Select
SelectQuestion (GetParNum(selection.Range))
selection.Copy
selection.Collapse (wdCollapseEnd)
Documents("Processed_StudyGuide.docx").Activate
selection.MoveEnd
selection.Paste
'reactivate last document
Documents(docA).Activate
x = x - 1
Next
'runs bookmark removal
removebookmarks (docA)
Documents(docB).Activate 'activate processed study guide
' If ActiveDocument.Bookmarks.Count > 0 Then
' FixRepeatedQuestions
' End If
removebookmarks (docB)
ActiveDocument.Save
Documents(docA).Activate
End Function
Sub removebookmarks(name As String)
'removes bookmarks from documents
Dim bkm As Bookmark
For Each bkm In ActiveDocument.Bookmarks
bkm.Delete
Next bkm
End Sub
Function DoFindReplace_Bkmk(ByRef FindText As Variant, Optional ReplaceText
As String) As Integer
Dim i As Integer
i = 0
Dim bkmark As String
With selection.Find
'set Find Parameters
.ClearFormatting
.Replacement.ClearFormatting
.Text = FindText
'If replacement text is not supplied replace with targetword to find
If ReplaceText = "" Then
.Replacement.Text = FindText
Else
.Replacement.Text = ReplaceText
End If
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
Do While .Execute
'Keep going until nothing found
.Execute Replace:=wdReplaceAll
'keep track of how many are replaced
'get bookmark name and add bookmark at location
bookmarkName = GetName(i)
ActiveDocument.Bookmarks.Add name:=bookmarkName, Range:=selection.Range
i = i + 1 'below because array starts at 0
Loop
'Free up some memory
ActiveDocument.UndoClear
End With
'return # of find/replacements
DoFindReplace_Bkmk = i
End Function
For Each i In arr() can't work.
Your Arr() is a string and the Each enumeration only works for objects. You would have to use
For i = 0 to Ubound(Arr)
Next i
Here is the complete code for repetitive searching. Note that the TestCount function prints its output to VBE's Immediate window. If you don't see it, press Ctl+G or select it from the View menu, or change the output to a MsgBox.
Sub TestCount()
' testing procedure
Dim MyPhrase As String
MyPhrase = "International business"
Debug.Print "My phrase was found " & CountWords(MyPhrase) & " times."
End Sub
Function CountWords(Phrase As String) As Integer
' 12 Apr 2017
' return the number of occurences of words in document
Dim Fun As Integer ' Function return value
Dim Rng As Range
Set Rng = ActiveDocument.Content
Do
With Rng.Find
.ClearFormatting
.MatchCase = False
.Text = Phrase
.Execute
If Not .Found Then Exit Do
Fun = Fun + 1
End With
Loop
CountWords = Fun
End Function
For your understanding:-
Find always starts the search at the beginning of the range you set. At the start of the procedure the range is defined as ActiveDocument.Content.
When a match is found, the range is reset to hold only the found phrase, meaning Rng isn't the same as it was before.
The loop now repeats the search with the changed Rng object, again starting at the beginning of that range to the end of the document.
When no more match is found the loop is exited. It's important, not to Wrap because that property instructs Find to continue looking for matches at the beginning of the document when no match is found before its end.
In between, in the place where you now see Fun = Fun + 1, you could execute any code you like - perhaps call a sub there which makes major changes or even copies parts of the document to another document. The important thing is that, after you come back from all that work, the Rng pointer still holds that part of the document from where you want to continue your search.
O hope this will speed you on your way.
I am working on an automated peer review macro that would check for certain words and highlight them in a Microsoft Word document. However, I am looking to substitute the WordList = Split(" is , are ,", ",") with a list I created in excel. This would be easier for me to add new words instead of manually typing the words I want highlighted in the code.
For example: A1 has the word " is ", so I am hoping it would be something like Wordlist = Split("A1, A2")
or something like Exlist = Range("A1:A2").value so WordList = Split(ExList)
Is something like that possible? Thank you for your help.
Sub PeerReview()
Dim r As Range
Dim WordList() As String
Dim a As Long
Dim Doc As Document
Dim Response As Integer
'This code will search through all of the open word documents and ask you which ones you would like to peer review.
For Each Doc In Documents
'MsgBox Doc
Response = MsgBox(prompt:="Do you want to peer review " & Doc & "?", Buttons:=vbYesNo)
If Response = vbNo Then GoTo ShortCut
'This code will highlight words that do not belong in the paragraph
WordList = Split(" is , are ,", ",") 'List of words to check for when it is peer-reviewing
Options.DefaultHighlightColorIndex = wdPink *'Highlight when found*
For a = 0 To UBound(WordList())
Set r = ActiveDocument.Range
With r.Find
.Text = WordList(a)
.Replacement.Highlight = wdYellow
.Execute Replace:=wdReplaceAll
End With
Next 'next word
ShortCut:
Next
End Sub
Here are three ways to retrieve an array of words from an external file (Word, Excel, and Text Files) in MS Word. Reading from the text file is by far the fastest.
Results
Word: 0.328125 Seconds
Excel: 1.359130859375 Seconds
Text: 0.008056640625 Seconds
---------- ----------
Get Word List from Word Document
Start Time:12/1/2007 11:03:56 PM
End Time:9/1/2016 12:53:16 AM
Duration:0.328125 Seconds
------------------------------
---------- ----------
Get Word List from Excel
Start Time:12/1/2007 3:05:49 PM
End Time:9/1/2016 12:53:17 AM
Duration:1.359130859375 Seconds
------------------------------
---------- ----------
Get Word List from Text Document
Start Time:11/30/2007 6:16:01 AM
End Time:9/1/2016 12:53:17 AM
Duration:0.008056640625 Seconds
------------------------------
Unit Test
Sub TestWordList()
Dim arData
EventsTimer "Get Word List from Word Document"
arData = GetWordsListDoc
'Debug.Print Join(arData, ",")
EventsTimer "Get Word List from Word Document"
EventsTimer "Get Word List from Excel"
arData = GetWordsListXL
'Debug.Print Join(arData, ",")
EventsTimer "Get Word List from Excel"
EventsTimer "Get Word List from Text Document"
arData = GetWordsListTxt
'Debug.Print Join(arData, ",")
EventsTimer "Get Word List from Text Document"
End Sub
Event Timer
Sub EventsTimer(Optional EventName As String)
Static dict As Object
If dict Is Nothing Then Set dict = CreateObject("Scripting.Dictionary")
If dict.Exists(EventName) Then
Debug.Print
Debug.Print String(10, "-"), String(10, "-")
Debug.Print EventName
Debug.Print ; "Start Time:"; ; Now - dict(EventName)
Debug.Print ; "End Time:"; ; Now
Debug.Print ; "Duration:"; ; Timer - dict(EventName) & " Seconds"
Debug.Print String(10, "-"); String(10, "-"); String(10, "-")
dict.Remove EventName
Else
dict.Add EventName, CDbl(Timer)
End If
If dict.Count = 0 Then Set dict = Nothing
End Sub
Functions to retrieve a word list from MS Word, Ms Excel and a Text File.
Function GetWordsListDoc()
Const FilePath As String = "C:\Users\best buy\Downloads\stackoverfow\Wordlist\WordList.docx"
Dim doc As Word.Document, oWords As Word.Words
Dim x As Long
Dim arData
Set doc = Application.Documents.Open(FileName:=FilePath, ReadOnly:=True)
Set oWords = doc.Words
ReDim arData(oWords.Count - 1)
For x = 1 To oWords.Count
arData(x - 1) = Trim(oWords.Item(x))
Next
doc.Close False
GetWordsListDoc = arData
End Function
Function GetWordsListXL()
Const FilePath As String = "C:\Users\best buy\Downloads\stackoverfow\Wordlist\WordsList.xlsb"
Const xlUp = -4162
Dim arData
Dim x As Long
Dim oExcel As Object, oWorkbook As Object
Set oExcel = CreateObject("Excel.Application")
With oExcel
.Visible = False
Set oWorkbook = .Workbooks.Open(FileName:=FilePath, ReadOnly:=True)
End With
With oWorkbook.Worksheets(1)
arData = .Range("A1", .Range("A" & .Rows.Count).End(xlUp)).Value
arData = oExcel.WorksheetFunction.Transpose(arData)
End With
oWorkbook.Close False
oExcel.Quit
GetWordsListXL = arData
End Function
Function GetWordsListTxt()
Const FilePath As String = "C:\Users\best buy\Downloads\stackoverfow\Wordlist\WordList.txt"
Dim arData, f, fso
Set fso = CreateObject("Scripting.Filesystemobject")
Set f = fso.OpenTextFile(FilePath)
arData = Split(f.ReadAll, vbNewLine)
GetWordsListTxt = arData
End Function
I am exporting an excel table into word using VBA. The word document has one bookmark. The code is such that first it writes the TYPE as the heading and then write all the description under that TYPE. I want the headings to be bold and formatted. I have the following code but it does not work. If anyone could suggest something.
If Dir(strPath & "\" & strFileName) <> "" Then
'Word Document open
On Error Resume Next
Set objWDApp = GetObject(, "Word.Application")
If objWDApp Is Nothing Then Set objWDApp = CreateObject("Word.Application")
With objWDApp
.Visible = True 'Or True, if Word is to be indicated
.Documents.Open (strPath & "\" & strFileName)
Set objRng = objWDApp.ActiveDocument.Bookmarks("Bookmark").Range
.Styles.Add ("Heading")
.Styles.Add ("Text")
With .Styles("Heading").Font
.Name = "Arial"
.Size = 12
.Bold = True
.Underline = True
End With
With .Styles("Text").Font
.Name = "Arial"
.Size = 10
.Bold = False
.Underline = False
End With
End With
On Error GoTo 0
i = Start_Cell
idx(1) = i
n = 2
Do ' Search for first empty cell in the table
i = i + 1
If i > Start_Cell + 1 And Cells(i, QB_Type).Value = Cells(i - 1, QB_Type) Then GoTo Loop1
idx(n) = i
n = n + 1
Loop1:
Loop Until IsEmpty(Cells(i + 1, QB_Type).Value)
idxEnd = i
idx(n) = 9999
i = Start_Cell
n = 1
Do
If i = idx(n) Then
strTMP = vbNewLine & vbNewLine & Cells(idx(n), QB_Type).Value & vbNewLine
With objWDApp
'.Selection.Font.Bold = True 'Type Bold (Doesnt Functions!?)
.Selection.Styles ("Heading") 'I tried this as well but not functioning...gives an error here that object does not support this property
WriteToWord objRng, strTMP 'Text written
End With
n = n + 1
End If
strTMP = vbNewLine & Cells(i, QB_Description).Value & vbNewLine
With objWDApp
' .Selection.Font.Bold = False 'Description Not bold (Not functioning!?)
.Selection.Styles("Text") 'This is also not functioning
WriteToWord objRng, strTMP 'Text written
End With
i = i + 1 'Arbeitspunktzähler erhöhen
Loop Until i > idxEnd
Public Sub WriteToWord(objRng, text)
With objRng
.InsertAfter text
End With
End Sub
Try .Selection.Style.Name = "Heading" from here
Edit 2
The following code works as expected. You will need to modify it to fit your needs. I successfully added and then bolded text to an existing word document.
Option Explicit
Public Sub Test()
' Add a reference to Microsoft Word x.0 Object Library for early binding and syntax support
Dim w As Word.Application
If (w Is Nothing) Then Set w = New Word.Application
Dim item As Word.Document, doc As Word.Document
' If the document is already open, just get a reference to it
For Each item In w.Documents
If (item.FullName = "C:\Path\To\Test.docx") Then
Set doc = item
Exit For
End If
Next
' Else, open the document
If (doc Is Nothing) Then Set doc = w.Documents.Open("C:\Path\To\Test.docx")
' Force change Word's default read-only/protected view
doc.ActiveWindow.View = wdNormalView
' Delete the preexisting style to avoid an error of duplicate entry next time this is run
' Could also check if the style exists by iterating through all styles. Whichever method works for you
doc.Styles.item("MyStyle").Delete
doc.Styles.Add "MyStyle"
With doc.Styles("MyStyle").Font
.Name = "Arial"
.Size = 12
.Bold = True
.Underline = wdUnderlineSingle
End With
' Do your logic to put text where you need it
doc.Range.InsertAfter "This is another Heading"
' Now find that same text you just added to the document, and bold it.
With doc.Content.Find
.Text = "This is another Heading"
.Execute
If (.Found) Then .Parent.Bold = True
End With
' Make sure to dispose of the objects. This can cause issues when the macro gets out mid way, causing a file lock on the document
doc.Close
Set doc = Nothing
w.Quit
Set w = Nothing
End Sub
By adding a reference to the object library, you can get intellisense support and compilation errors. It would help you determine earlier in development that Styles is not a valid property off the Word.Application object.