Automatic Excel Acronym finding, Definition and Classification Adding - vba

I have been working with code that I found HERE but I am having difficulty getting it to do one more task for me. I have added another column (3) to my excel document that has the "classification" of the acronym & definition and I want to add that to the newly created word doc in column 1, before the acronym. I have tried several different ways of moving the provided code around but it always results in an error. Any help is appreciated. I have included the working code below. Like I said, it works I just want it to do one more thing. Thank you!
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
'Create a variable for excel and open the definition workbook
Set objExcel = CreateObject("Excel.Application")
Set objWbk = objExcel.Workbooks.Open("C:\Users\USERNAME\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:=4)
With oTable
'Format the table a bit
'Insert headings
.Range.Style = wdStyleNormal
.AllowAutoFit = False
.Cell(1, 1).Range.Text = "Classification"
.Cell(1, 2).Range.Text = "Acronym"
.Cell(1, 3).Range.Text = "Definition"
.Cell(1, 4).Range.Text = "Page"
'Set row as heading row
.Rows(1).HeadingFormat = True
.Rows(1).Range.Font.Bold = True
.PreferredWidthType = wdPreferredWidthPercent
.Columns(1).PreferredWidth = 15
.Columns(2).PreferredWidth = 25
.Columns(3).PreferredWidth = 55
.Columns(4).PreferredWidth = 5
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(2, 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, 2).Range.Text = strAcronym
'Insert page number in column 4
.Cell(n + 1, 4).Range.Text = oRange.Information(wdActiveEndPageNumber)
' 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, 3).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 2", SortFieldType _
:=wdSortFieldAlphanumeric, SortOrder:=wdSortOrderAscending
'Go to start of document
.HomeKey (wdStory)
End With
End If
' 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
On Error Resume Next
AppActivate Application.Caption
On Error GoTo 0
MsgBox Msg, vbOKOnly, Title
'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

If anyone is looking for this solution, I was able to figure it out by duplicating the following lines. It then counts how many definitions and classifications it was unable to find and reports at the end.
' 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, 3).Range.Text = targetCellValue
End With

Related

Find the column related to comments contained in a cell of a MS Word table

I have a Word document containing a table with two columns
column 1 contains numbers
column 2 contains text
Users introduce comments on the text in column 2 (see drawing).
I can create a table putting together all the comments with this code.
How do I access the number of the other column with reference to the texts commented?
The result so far is like this:
I need the number in the first column next to the text containing the comment.
I guess there is a method similar to:
oDoc.Comments(n).Scope.Information(wdActiveEndPageNumber)
but accessing the table cell - and then I could refer to the same row and first column to grab the content of the first column?
Following is code that produces the table above. Be aware the code does not take into account that the comments are made on text belonging to table cells, Which is what I am looking for.
Sub ExtractCommentsToNewDocument()
'=========================
'Macro created 2007 by Lene Fredborg, DocTools - www.thedoctools.com
'Revised October 2013 by Lene Fredborg: Date column added to extract
'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.
'=========================
'The macro creates a new document
'and extracts all comments from the active document
'incl. metadata
'Minor adjustments are made to the styles used
'You may need to change the style settings and table layout to fit your needs
'=========================
Dim oDoc As Document
Dim oNewDoc As Document
Dim oTable As Table
Dim nCount As Long
Dim n As Long
Dim Title As String
Title = "Extract All Comments to New Document"
Set oDoc = ActiveDocument
nCount = ActiveDocument.Comments.Count
If nCount = 0 Then
MsgBox "The active document contains no comments.", vbOKOnly, Title
GoTo ExitHere
Else
'Stop if user does not click Yes
If MsgBox("Do you want to extract all comments to a new document?", _
vbYesNo + vbQuestion, Title) <> vbYes Then
GoTo ExitHere
End If
End If
Application.ScreenUpdating = False
'Create a new document for the comments, base on Normal.dot
Set oNewDoc = Documents.Add
'Set to landscape
oNewDoc.PageSetup.Orientation = wdOrientLandscape
'Insert a 4-column table for the comments
With oNewDoc
.Content = ""
Set oTable = .Tables.Add _
(range:=Selection.range, _
NumRows:=nCount + 1, _
NumColumns:=5)
End With
'Insert info in header - change date format as you wish
oNewDoc.Sections(1).Headers(wdHeaderFooterPrimary).range.Text = _
"Comments extracted from: " & oDoc.FullName & vbCr & _
"Created by: " & Application.UserName & vbCr & _
"Creation date: " & Format(Date, "MMMM d, yyyy")
'Adjust the Normal style and Header style
With oNewDoc.Styles(wdStyleNormal)
.Font.Name = "Arial"
.Font.Size = 10
.ParagraphFormat.LeftIndent = 0
.ParagraphFormat.SpaceAfter = 6
End With
With oNewDoc.Styles(wdStyleHeader)
.Font.Size = 8
.ParagraphFormat.SpaceAfter = 0
End With
'Format the table appropriately
With oTable
.range.Style = wdStyleNormal
.AllowAutoFit = False
.PreferredWidthType = wdPreferredWidthPercent
.PreferredWidth = 100
.Columns.PreferredWidthType = wdPreferredWidthPercent
.Columns(1).PreferredWidth = 5
.Columns(2).PreferredWidth = 23
.Columns(3).PreferredWidth = 42
.Columns(4).PreferredWidth = 18
.Columns(5).PreferredWidth = 12
.Rows(1).HeadingFormat = True
End With
'Insert table headings
With oTable.Rows(1)
.range.Font.Bold = True
.Cells(1).range.Text = "Page"
.Cells(2).range.Text = "Code"
.Cells(3).range.Text = "Text"
.Cells(4).range.Text = "Interview"
.Cells(5).range.Text = "Date"
End With
'Get info from each comment from oDoc and insert in table
For n = 1 To nCount
With oTable.Rows(n + 1)
'Page number
.Cells(1).range.Text = _
oDoc.Comments(n).Scope.Information(wdActiveEndPageNumber)
'The comment itself
.Cells(2).range.Text = oDoc.Comments(n).range.Text
'The text marked by the comment
.Cells(3).range.Text = oDoc.Comments(n).Scope
'The comment author
.Cells(4).range.Text = oDoc.Comments(n).Author
'The comment date in format dd-MMM-yyyy
.Cells(5).range.Text = Format(oDoc.Comments(n).Date, "dd-MMM-yyyy")
End With
Next n
Application.ScreenUpdating = True
Application.ScreenRefresh
oNewDoc.Activate
MsgBox nCount & " comments found. Finished creating comments document.", vbOKOnly, Title
ExitHere:
Set oDoc = Nothing
Set oNewDoc = Nothing
Set oTable = Nothing
End Sub
After:
.Cells(3).Range.Text = oDoc.Comments(n).Scope
Insert:
If oDoc.Comments(n).Scope.Information(wdWithInTable) = True Then
If oDoc.Comments(n).Scope.Cells(1).ColumnIndex > 1 Then
.Cells(3).Range.InsertBefore Split(oDoc.Comments(n).Scope.Rows(1).Cells(1).Range.Text, vbCr)(0) & vbTab
End If
End If

How do I split my one document into many at page breaks in VBA?

I am new to VBA. I got this macro from online and it has worked for me before, but now I am getting a runtime error from it.
The macro is supposed to take a mail merged document I have, and split it into individual documents for each recipient.
The runtime error 5487 is pointing me to the line
" .SaveAs fileName:=StrTxt &...".
I have tried to save it as a different file format, and have gone through the other posts on StackOverflow where others have the same error, but I am still getting the error message.
My code is:
Sub SplitMergedDocument()
' Source: http://msofficeforums.com/mail-merge/21803-mailmerge-tips-tricks.html
Const StrNoChr As String = """*./\:?|"
Dim i As Long, j As Long, k As Long, StrTxt As String
Dim Rng As Range, Doc As Document, HdFt As HeaderFooter
Application.ScreenUpdating = False
j = InputBox("How many Section breaks are there per record?", "Split By Sections ", 1)
With ActiveDocument
For i = 1 To .Sections.Count - 1 Step j ' Process each Section
With .Sections(i)
Set Rng = .Range.Paragraphs(1).Range ' Get 1st paragraph
With Rng
.MoveEnd wdCharacter, -1 'range to exclude final paragraph break
StrTxt = .Text
For k = 1 To Len(StrNoChr)
StrTxt = Replace(StrTxt, Mid(StrNoChr, k, 1), "_")
Next
End With
' Construct destination file path & name
StrTxt = ActiveDocument.Path & Application.PathSeparator & StrTxt
Set Rng = .Range ' Get whole Section
With Rng
If j > 1 Then .MoveEnd wdSection, j - 1
.MoveEnd wdCharacter, -1 'Contract range to exclude Section break
.Copy ' Copy range
End With
End With
' Create output document
Set Doc = Documents.Add(Template:=ActiveDocument.AttachedTemplate.FullName _
, Visible:=False)
With Doc
' Paste contents into output document, preserving formatting
.Range.PasteAndFormat (wdFormatOriginalFormatting)
' Delete trailing paragraph breaks & page breaks at end
While .Characters.Last.Previous = vbCr Or .Characters.Last.Previous = Chr(12)
.Characters.Last.Previous = vbNullString
Wend
For Each HdFt In Rng.Sections(j).Headers ' Replicate headers & footers
.Sections(j).Headers(HdFt.Index).Range.FormattedText = HdFt.Range.FormattedText
Next
For Each HdFt In Rng.Sections(j).Footers
.Sections(j).Footers(HdFt.Index).Range.FormattedText = HdFt.Range.FormattedText
Next
' Save & close output document
.SaveAs FileName:=StrTxt & ".docx", FileFormat:=wdFormatXMLDocument _
, AddToRecentFiles:=False
.Close SaveChanges:=False
End With
Next
End With
Set Rng = Nothing: Set Doc = Nothing
Application.ScreenUpdating = True
End Sub
Thank you!
Without knowing more (such as the value of StrTxt), I can't say for sure why you're getting the error but it's likely either an invalid filename, or the file is locked by another process, or a permissions issue.
Perhaps the procedure below will work better for you. (I'm unclear on the significance of "records" in your code.)
Split document into separate files for each page:
This procedure splits the ActiveDocument into one .DOCX file per "visible page" (calculated page breaks, manual page breaks, section breaks, etc).\
Sub WordDocToPages()
'splits active Word doc by page into separate DOCX files (same folder as active doc)
Dim doc As Document, docPage As Document, rgPage As Range
Dim pgNum As Long, pgCnt As Long, ext As String, fName As String
Set doc = ActiveDocument 'Use current document
Set rgPage = doc.Range 'create range of 1 page
Application.ScreenUpdating = False 'prevent screen updates
pgCnt = doc.Content.Information(wdNumberOfPagesInDocument) 'get page count
Do While pgNum < pgCnt
pgNum = pgNum + 1 'increment page counter
Application.StatusBar = "Saving page " & pgNum & " of " & pgCnt
If pgNum < pgCnt Then
Selection.GoTo wdGoToPage, wdGoToAbsolute, pgNum + 1 'top of next page
rgPage.End = Selection.Start 'end of page=top of next
Else
rgPage.End = doc.Range.End 'end of last page=EOF
End If
rgPage.Copy 'copy page
Set docPage = Documents.Add(Visible:=False) 'create new document
With docPage
With .Range
.Paste 'paste page
.Find.Execute Findtext:="^m", ReplaceWith:="" 'remove manual breaks
.Select
End With
With Selection
.EndKey wdStory 'goto end of doc
.MoveLeft wdCharacter, 1, wdExtend 'remove final CR
If Asc(.Text) = 13 Then .Delete wdCharacter, 1 'remove trailing CR
End With
ext = Mid(doc.FullName, InStrRev(doc.FullName, ".")) 'extract file extension
fName = Replace(doc.FullName, ext, " #" & _
Format(pgNum, String(Len(CStr(pgCnt)), "0")) & ".docx") 'new filename
.SaveAs fName, wdFormatDocumentDefault 'save single-page doc
.Close 'close new document
End With
rgPage.Collapse wdCollapseEnd 'ready for next page
Loop
Application.ScreenUpdating = True 'resume screen updates
Application.StatusBar = "Document was split into " & pgNum & " files."
Set docPage = Nothing: Set rgPage = Nothing: Set doc = Nothing 'cleanup objects
End Sub
This is loosely based on the example at Usefulware Sharing.
The new files are saved to the same folder as ActiveDocument.Path, with the document title appended with a sequential number. Note that existing output files are overwritten, and there is no validation or error handling.

new line is getting added in table().cell().range.text in word macro

When I copy text from a cell in table using docCurrent.Tables(x).Cell(x, y).Range.Text, a new line is getting added along with the text in the cell.
The code I used is:
Sub tabele_trasfer()
'
' tabele_trasfer Macro
'
'
Dim docCurrent As Document
Dim docNew As Document
Dim myRange As Range
Set docCurrent = ActiveDocument
Set docNew = Documents.Add
Set myRange = docNew.Range(0, 0)
docNew.Tables.Add Range:=myRange, NumRows:=docCurrent.Tables(5).Rows.Count, NumColumns:=docCurrent.Tables(5).Columns.Count
For i = 1 To docCurrent.Tables(5).Rows.Count
docNew.Tables(1).Cell(Row:=i, Column:=1).Range.Text = docCurrent.Tables(5).Cell(i, 2).Range.Text
docNew.Tables(1).Cell(Row:=i, Column:=2).Range.Text = docCurrent.Tables(5).Cell(i, 2).Range.Text
Next i
End Sub
The reason is that the end of a table cell contains two characters: Chr(13) & Chr(7) - a paragraph mark and the end-of-cell marker. You can cut these off to retain only the text.
I've provided a function I use for this purpose that takes the cell Range and returns the string value, below. Here's one of your lines, altered to use the function
docNew.Tables(1).Cell(Row:=i, Column:=1).Range.Text = _
TrimCellText(docCurrent.Tables(5).Cell(i, 2).Range)
And the function
Function TrimCellText(r As word.Range) As String
Dim sLastChar As String
Dim sCellText As String
sCellText = r.Text
sLastChar = Right(sCellText, 1)
Do While sLastChar = Chr(7) Or sLastChar = Chr(13)
sCellText = Left(sCellText, Len(sCellText) - 1)
sLastChar = Right(sCellText, 1)
Loop
TrimCellText = sCellText
End Function
You seem to be populating both columns in the new document with the same data. Try:
Sub tabele_trasfer()
'
' tabele_trasfer Macro
'
'
Dim docCurrent As Document
Dim docNew As Document
Dim myRange As Range
Set docCurrent = ActiveDocument
Set docNew = Documents.Add
Set myRange = docNew.Range(0, 0)
docNew.Tables.Add Range:=myRange, NumRows:=docCurrent.Tables(5).Rows.Count, NumColumns:=docCurrent.Tables(5).Columns.Count
For i = 1 To docCurrent.Tables(5).Rows.Count
Set myRange = docCurrent.Tables(5).Cell(i, 2).Range
myRange.End = myRange.End - 1
docNew.Tables(1).Cell(i, 1).Range.Text = myRange.Text
docNew.Tables(1).Cell(i, 2).Range.Text = myRange.Text
Next i
End Sub
If populating both columns in the new document with the same data is not your intent, use:
Set myRange = docCurrent.Tables(5).Cell(i, 2).Range
myRange.End = myRange.End - 1
again to point to the correct source before outputting the second string.

Making Certain Text Bold In Excel VBA

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.

Using Multiple wildcard searches in Word 2007 with VBA

I have VBA code that runs through a document and identifies acronyms using wildcards and places them in a separate word document. Some of my writers don't always follow the proper style guides for acronyms so I'm running four different scripts to find all the possible acronyms. It's time consuming and I end up with multiple documents. Is there a method to run multiple searches from one script and have all the results placed in the separate document. Truth in Advertising: I found this script on the 'net, but I've been playing with it to attempt to make it do some other features. Adding current script:
Sub ExtractVariousValuesACRONYMSToNewDocument()
'The macro creates a new document,
'finds all words consisting of 2 or more uppercase letters
'in the active document and inserts the words
'in column 1 of a 3-column table in the new document
'Each acronym is added only once
'Use column 2 for definitions
'Page number of first occurrence is added by the macro in column 3
'Minor adjustments are made to the styles used
'You may need to change the style settings and table layout to fit your needs
'=========================
Dim oDoc_Source As Document
Dim oDoc_Target As Document
Dim strListSep As String
Dim strAcronym 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 2 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:=3)
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 2 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]{2" & 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
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
The best solution would be one searching pattern for all cases. Word hasn't full regular expressions, it is not always possible. Write all four patterns, maybe there is a way for join them into one super-pattern.
The second possibility is running multiple times the same algorithm in one macro, something like this:
Sub Example()
Dim patterns As String
Dim pts() As String
'list of patterns for each run delimited by a delimiter - comma in this example
patterns = "first pattern, second pattern, and so on"
pts = Split(patterns, ",") 'the second parameter is a delimiter
Dim i As Integer
For i = 0 To UBound(pts)
'do your subroutine for each searching pattern
Next i
'save document with result
End Sub
For better answer give us more details, please.