Using Multiple wildcard searches in Word 2007 with VBA - 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.

Related

Get heading information using a wild card search loop in MS Word using VBA

I am doing a wildcard search loop in MS Word and generating the list of all the find values in a new document using following code. I have added page numbers to the output. But I can't think of how to get the headers for the searched output. Pls suggest.
Sample Word Document:
1 Heading
Text Text Text Text Text
--<Page Break>--
1.1 Heading
Text Text Text Text Text [Reference X1]
1.1.1 Heading
Text Text Text Text Text
Text Text Text Text Text
Text Text Text Text Text
--<Page Break>--
1.2 Heading
Text Text Text Text Text
1.2.1 Heading
Text Text Text Text Text
Text Text Text Text Text [Reference X2]
Text Text Text Text Text [Reference X3]
The 1, 1.1, etc headings are the default heading styles used in MS word. (For me the style name is "Heading 1", "Heading 2", etc.)
The output I am expecting is as under in a tabular format:
| Reference | Heading | Page |
| Reference X1 | 1.1 Heading | 2 |
| Reference X2 | 1.2.1 Heading | 3 |
| Reference X2 | 1.2.1 Heading | 3 |
The Code (part of the sub that does this finding and writing in the table) I have been able to write so far is:
With oDoc
Set oRange = .Range
n = 1
With oRange.Find
.Text = "<Reference X[0-9]{1,}>"
.Forward = True
.MatchWildcards = True
Do While .Execute
strFound = oRange
With oTable
.Cell(n+1,1).Range.Text = strFound
.Cell(n+1,3).Range.Text = oRange.Information(wdActiveEndPageNumber)
End With
n = n + 1
Loop
End With
End With
I already have the code for defining these variables, creating a table and required rows in it. I am only confused about how to get the heading just above the found item. The issue is there can be one or multiple "Reference XX" under one heading. Further, the heading level can be any. And I need separate rows for each item found using the wildcard.
For example:
Sub GetRefHeadings()
Application.ScreenUpdating = False
Dim Rng As Range, StrOut As String, Tbl As Table
StrOut = "Ref." & vbTab & "Heading" & vbTab & "Page" & vbCr
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "<Reference X[0-9]#>"
.Replacement.Text = ""
.Format = False
.Forward = True
.Wrap = wdFindStop
.MatchWildcards = True
End With
Do While .Find.Execute
Set Rng = .Paragraphs(1).Range
Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
StrOut = StrOut & .Text & vbTab & Rng.Paragraphs.First.Range.ListFormat.ListString & _
" " & Split(Rng.Text, vbCr)(0) & vbTab & Rng.Information(wdActiveEndPageNumber) & vbCr
Loop
End With
Set Rng = ActiveDocument.Range.Characters.Last
Rng.Text = StrOut
Set Tbl = Rng.ConvertToTable(Separator:=vbTab)
With Tbl
.PreferredWidthType = wdPreferredWidthPercent
.PreferredWidth = 100
.Columns.PreferredWidthType = wdPreferredWidthPercent
.Columns(1).PreferredWidth = 20
.Columns(2).PreferredWidth = 70
.Columns(3).PreferredWidth = 10
.Rows(1).Range.Font.Bold = True
.Rows(1).HeadingFormat = True
'.Sort ExcludeHeader:=True, FieldNumber:=1
End With
Set Rng = Nothing: Set Tbl = Nothing
Application.ScreenUpdating = True
End Sub
If you want the found text's page # instead of the heading's page #, change Rng.Information to .Information.
The default sort order is by reference found, regardless of the Reference #, which coincides with sorting by Heading. The code also includes a commented-out line to sort by Reference # instead.
You can find the heading level of the section of text you've found using a predefined bookmark. Since this trick uses the Selection object, you have to transfer the "found text" range to Selection. This code snippet below shows how:
Option Explicit
Sub test()
With ActiveDocument
Dim foundThis As Range
Set foundThis = .Range
With foundThis.Find
.Text = "<Reference X[0-9]{1,}>"
.Forward = True
.MatchWildcards = True
Do While .Execute
Dim strFound As String
Dim heading As String
strFound = foundThis.Text
heading = foundThis.GoTo(What:=wdGoToBookmark, _
Name:="\HeadingLevel").Paragraphs(1).Range.Text
Debug.Print "string found: " & strFound & " on page " & _
foundThis.Information(wdActiveEndPageNumber) & _
", Heading: " & heading
Loop
End With
End With
End Sub

Word VBA: recursive word search and work count

I am trying to create a Word macro VBA to do the following:
for the active Word document
find the name “Bob” and count how many times “this is new” is associated to Bob (recursion search and count)
For example. Bob = 2, Matthew = 1, Mark = 0
Report – JP
PQR – Bob, Mark
· Some text
Report – SH
JKL – Bob, Mark
· Some text
GHI – Bob
· This is new.
· More text
Report – JM
MNO – Bob, Mark
· Some text
DEF – Bob
· This is new.
· More text
ABC – Matthew
· This is new.
· More text
Report – BB
PQR – Bob, Mark
· Some text
I believe that my attempt using this code is not correct. Any help?
sResponse = "is new"
iCount = 0
Application.ScreenUpdating = False
With Selection
.HomeKey Unit:=wdStory
With .Find
.ClearFormatting
.Text = sResponse
' Loop until Word can no longer
' find the search string and
' count each instance
Do While .Execute
iCount = iCount + 1
Selection.MoveRight
Loop
End With
MsgBox sResponse & " appears " & iCount & " times
For example:
Sub Demo()
Application.ScreenUpdating = False
Dim StrNm As String, StrOut As String, i As Long
StrOut = "Bob = 0, " & _
"Matthew = 0, " & _
"Mark = 0, "
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "<[! ]# · This is new"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = True
End With
Do While .Find.Execute
If .Text = "" Then Exit Do
StrNm = Split(.Text, " ")(0)
If InStr(StrOut, StrNm) > 0 Then
i = Split(Split(StrOut, StrNm & " = ")(1), ", ")(0)
StrOut = Replace(StrOut, StrNm & " = " & i, StrNm & " = " & i + 1)
Else
StrOut = StrOut & StrNm & " = " & 1 & ", "
End If
.Collapse wdCollapseEnd
Loop
End With
Application.ScreenUpdating = True
MsgBox "Frequency Report:" & StrOut
End Sub
If you've missed any names with 'This is new', the code above will simply add them to the pre-defined StrOut list.
A part of your stated original problem was that you wanted to list ALL of the names, including names that NEVER show up as lines with the phrase "This is new". So the code must build a Dictionary of names and keep track of each name and its count as all the lines are scanned. (See this site for good information on dictionaries.)
There are a couple of "gotchas" in the ultimate solution, including allowing for names with accented characters (e.g. José) and names with spaces (e.g. "Bob Smith"). So I created a special "trim" function to scan each name and make sure the string is really just the name.
Assumptions:
Lines that DO NOT begin with "Report" are the lines that have names
The words separated by commas after the dash character are the names
The list of names ends when you find the special "separator" character
Here is the example code:
Option Explicit
Sub CountPhrase()
'--- define the dash and separator characters/strings - may be special codes
Dim dash As String
Dim separator As String
Dim phrase As String
dash = "–" 'this is not a keyboard dash
separator = "·" 'this is not a keyboard period
phrase = "This is new"
Dim nameCount As Scripting.Dictionary
Set nameCount = New Scripting.Dictionary
Dim i As Long
For i = 1 To ThisDocument.Sentences.Count
'--- locate the beginning of the names lines (that DO NOT have start with "Report")
If Not (ThisDocument.Sentences(i) Like "Report*") Then
'--- pick out the names for this report
Dim dashPosition As Long
Dim separatorPosition As Long
dashPosition = InStr(1, ThisDocument.Sentences(i), dash, vbTextCompare)
separatorPosition = InStr(1, ThisDocument.Sentences(i), separator, vbTextCompare)
Dim names() As String
names = Split(Mid$(ThisDocument.Sentences(i), _
dashPosition + 1, _
separatorPosition - dashPosition), ",")
'--- now check if the phrase exists in this sentence or not
Dim phrasePosition As Long
phrasePosition = InStr(1, ThisDocument.Sentences(i), phrase, vbTextCompare)
'--- add names to the dictionary if they don't exist, and increment
' the name count if the phrase exists in this sentence
Dim name As Variant
For Each name In names
Dim thisName As String
thisName = SpecialTrim$(name)
If Len(thisName) > 0 Then
If nameCount.Exists(thisName) Then
If phrasePosition > 0 Then
nameCount(thisName) = nameCount(thisName) + 1
End If
Else
If phrasePosition > 0 Then
nameCount.Add thisName, 1
Else
nameCount.Add thisName, 0
End If
End If
End If
Next name
End If
Next i
'--- show your work
Dim popUpMsg As String
popUpMsg = "Frequency Report:"
For Each name In nameCount.Keys
popUpMsg = popUpMsg & vbCrLf & name & _
": count = " & nameCount(name)
Next name
MsgBox popUpMsg, vbInformation + vbOKOnly
End Sub
Function SpecialTrim(ByVal inString As String) As String
'--- this function can be tricky, because you have to allow
' for characters with accents and you must allow for names
' with spaces (e.g., "Bob Smith")
'--- trim from the left until the first allowable letter
Dim keepString As String
Dim thisLetter As String
Dim i As Long
For i = 1 To Len(inString)
thisLetter = Mid$(inString, i, 1)
If LetterIsAllowed(thisLetter) Then
Exit For
End If
Next i
'-- special case: if ALL of the letters are not allowed, return
' an empty string
If i = Len(inString) Then
SpecialTrim = vbNullString
Exit Function
End If
'--- now transfer allowable characters to the keeper
' we're done when we reach the first unallowable letter (or the end)
For i = i To Len(inString)
thisLetter = Mid$(inString, i, 1)
If LetterIsAllowed(thisLetter) Then
keepString = keepString & thisLetter
Else
Exit For
End If
Next i
SpecialTrim = Trim$(keepString)
End Function
Function LetterIsAllowed(ByVal inString As String) As Boolean
'--- inString is expected to be a single character
' NOTE: a space " " is allowed in the middle, so the caller must
' Trim the returned string
Const LETTERS = " abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" & _
"àáâãäåçèéêëìíîïðñòóôõöùúûüýÿŠŽšžŸÀÁÂÃÄÅÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖÙÚÛÜÝ"
Dim i As Long
For i = 1 To Len(LETTERS)
If inString = Mid$(LETTERS, i, 1) Then
LetterIsAllowed = True
Exit Function
End If
Next i
LetterIsAllowed = False
End Function

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

Automatic Excel Acronym finding, Definition and Classification Adding

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

Header 2 text does not match the exact same text in excel : VBA

I am creating a project that lets the user create a task list within excel and then compares the user created tasks-text to the second header-text, (Header 2) within a pre-made word document. I am able to get the second header text and save it to an array, and then get the user task list and save that within an array. I then try and see if the task text that is within the Program (The second headers) are within the user task list using the function
If IsError(Application.Match(ProgArray(x), TaskArray, 0)) Then
'Find within word document and highlight red
End if
The problem I am getting is that this always returns with an error because for some reason, even though the built in watch screen debugger says otherwise, the text within the word document does not equal the exact same text within the excel sheet.
At first I used a comparing text software to determine that the header's text from word might have actually copied an extra line.
Picture of explanation:
But then I tried to trim, and check for whether or not the header text had vbNewLine
If Right$(StrFound, 2) = vbCrLf Or Right$(StrFound, 2) = vbNewLine Then
Also to no avail, as this if statement was never triggered.
My question is, is taking text from a word document also pulling some hidden value that I am just missing, and if so is there any way around this? Thank you and sorry for the wall of text.
Lastly here is my complete code: (Its not pretty as I am just going for functionality right now)
'Sub CheckHeader()
Dim blnFound As Boolean
Dim StrFound As String
Dim x As Integer, y As Integer, z As Integer
Dim TaskTotal As Integer
Dim ProgArray(149) As String
Dim TaskArray() As String
Dim NotInArray() As String
Dim NotInProg() As String
Dim appWd As Object
Dim TaskSheet As Worksheet
Set appWd = GetObject(, "Word.Application")
Set wdFind = appWd.Selection.Find
Set TaskSheet = Sheets("Task List")
'Get Task List from Excel
TaskTotal = TaskSheet.Cells(TaskSheet.Rows.Count, 1).End(xlUp).Row - 1
ReDim TaskArray(TaskTotal) As String
ReDim NotInProg(TaskTotal) As String
ReDim NotInArray(TaskTotal) As String
'Get User task list into an array to compare - 0 to 0 is for testing
For x = 0 To 0 'TaskTotal - 1
TaskArray(x) = TaskSheet.Cells(2 + x, 5).Value '+ " (" & TaskSheet.Cells(2 + x, 1).Value + " " _
& TaskSheet.Cells(2 + x, 3).Value + ": " & TaskSheet.Cells(2 + x, 4).Value + ")"
Next x
x = 0
y = 0
'Find all instances of Headings
With ActiveDocument.Range.Find
'.Text = "Test"
.Style = "Heading 2"
Do
blnFound = .Execute
If blnFound Then
'MsgBox .Parent.Text
StrFound = .Parent.Text
'StrFound = Right(StrFound, InStr(StrFound, ")") + 1)
StrFound = CStr(StrFound)
TaskSheet.Cells(2 + x, 120).Value = StrFound
'At first I thought it was also saving a new line but I couldn't get rid of it
If Right$(StrFound, 2) = vbCrLf Or Right$(StrFound, 2) = vbNewLine Then
z = 1
End If
ProgArray(x) = TaskSheet.Cells(2 + x, 120)
'StrFound
x = x + 1
Else
Exit Do
End If
Loop
End With
'Compare if List is in Program
For x = 0 To 149
If x < TaskTotal - 1 Then
If IsError(Application.Match(TaskArray(x), ProgArray, 0)) Then
NotInProg(y) = TaskArray(x)
y = y + 1
End If
End If
'If the header is not within the user created task list then run this case
If IsError(Application.Match(ProgArray(x), TaskArray, 0)) Then
'used for debugging, for some reason the header text is larger than the user text
MsgBox StrComp(ProgArray(x), TaskArray(x))
NotInArray(z) = ProgArray(x)
SearchName = NotInArray(z)
'Increase element
z = z + 1
'Check Program and highlight to show that what is in the program is not in the user task list
With wdFind
.Text = SearchName
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Execute
End With
If wdFind.Found Then
'MsgBox " Found it"
appWd.Selection.Range.HighlightColorIndex = wdRed
Else
MsgBox ProgArray(x) + " is not in TaskList"
End If
Else
'Otherwise it is in the program and if it was red, unhighlight the text
SearchName = TaskArray(x)
With wdFind
.Text = SearchName
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Execute
End With
If wdFind.Found Then
'MsgBox " Found it"
appWd.Selection.Range.HighlightColorIndex = wdNoHighlight
' For not in task Selection.Range.HighlightColorIndex = wdRed
' For not in prog Selection.Range.HighlightColorIndex = wdYellow
Else
MsgBox TaskArray(x) + " is not here"
End If
End If
'Lastly Check for Ordering
Next x
End Sub'
There are two problems within your code and solutions to them are as follows:
To cut new paragraph mark we need to cut it of in this way:
.Parent.SetRange .Parent.Start, .Parent.End - 1
Which you need to put just before:
StrFound = .Parent.Text
Additionally, add .Parent.MoveEnd right after x=x+1 inside your do...loop.