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.
Related
Sub AcronymParser()
'Declare variables
Dim AcronymList As New Collection
Dim Acronym As String
Dim Definition As String
Dim Rng As Range
Dim Doc As Document
Dim AcroTable As Table
'Set the document object
Set Doc = ActiveDocument
'Iterate through the document and find all acronyms
For Each Rng In Doc.Words
If Rng.Font.Bold And Rng.Characters(1).Font.AllCaps And Rng.Characters(2).Font.AllLower Then
'Add the acronym to the list, along with its definition
Acronym = Rng.Text
Definition = Rng.Next.Text
AcronymList.Add Definition, Acronym
End If
Next Rng
'Create a new table
Set AcroTable = Doc.Tables.Add(Range:=Doc.Content, NumRows:=AcronymList.Count + 1, NumColumns:=2)
'Set the column widths
AcroTable.Columns(1).SetWidth ColumnWidth:=InchesToPoints(1), RulerStyle:=wdAdjustNone
AcroTable.Columns(2).SetWidth ColumnWidth:=InchesToPoints(3), RulerStyle:=wdAdjustNone
'Add the headings for the table
AcroTable.Cell(1, 1).Range.Text = "Acronym"
AcroTable.Cell(1, 2).Range.Text = "Definition"
'Iterate through the acronym list and add the acronyms and definitions to the table
For i = 1 To AcronymList.Count
AcroTable.Cell(i + 1, 1).Range.Text = AcronymList.Keys(i - 1)
AcroTable.Cell(i + 1, 2).Range.Text = AcronymList(i)
Next i
End Sub
I tried the above script with the expectation that it would run. For some reason, I keep getting the same error. Not sure what to do here.
I am writing Word VBA that:
(1) assigns values from a Word table to VBA variables,
(2) cleans the variables' values of non-text,
(3) uses the variables' names and values to create Bookmarks in that same bookmark_value cell of the table, and
(4) repeats 1-2-3 until the end of table.
This table is the first table in the document and has two columns, something like this:
_________________________________
| bookmark_name | bookmark_value|
| bm1 | 88 |
| foo | 66 |
|_____bar_______|______44_______|
The code picks up the bookmark_names and posts into Word Bookmarks, and also picks up the bookmark_values but fails to clean the table coding out of the value.
The result is the Bookmarks displaying these unwanted cells in Word with the value inside it. It is strange that first column works and not the second.
Some things I tried:
I found on the Internet and on this site, what I thought were solutions, those are marked in the code below with comments, the header saying, "tried and failed".
I am nearly sure I need to "unformat" the text, or something like that.
Public Sub BookmarkTable()
Dim selectedTable As Table
Dim curRow As Range
Dim rngSelect1 As Range
Dim rngSelect2 As Range
Dim intTableIndex As Integer
Dim rng As Range
Dim Cell1 As Cell, Cell2 As Cell
Dim strBookmarkName As String, strBookmarkValue As String, strBV As String
Dim strTstBookmark As String
Dim Col1 As Integer, Col2 As Integer
Dim i As Integer, t As Integer
Dim intRow As Integer
' Dim
Col1 = 1 'set the bookmark name from column 1
Col2 = 2 'set the bookmark's value from column 2
'For t = 1 To ActiveDocument.Tables.Count
t = 1 'select the Table to use(only using the first table right now)
Set selectedTable = ActiveDocument.Tables(t)
selectedTable.Select 'selects the table
For intRow = 2 To selectedTable.Rows.Count 'iterate through all rows
If Selection.Information(wdWithInTable) Then
Set Cell1 = ActiveDocument.Tables(t).Cell(intRow, Col1)
Set Cell2 = ActiveDocument.Tables(t).Cell(intRow, Col2)
Cell2.Select
intTableIndex = ActiveDocument.Range(0, Selection.Tables(1).Range.End).Tables.Count
rngColumnStart = Selection.Information(wdStartOfRangeColumnNumber)
rngRowStart = Selection.Information(wdStartOfRangeRowNumber)
End If
strTstBookmark = "BM_Table" & CStr(intTableIndex) & "_R" & CStr(rngRowStart) & "_C" & CStr(rngColumnStart)
' strBookmarkValue = strTstBookmark
Set rngSelect1 = ActiveDocument.Range(Start:=Cell1.Range.Start, End:=Cell1.Range.End - 1)
strBookmarkName = Strip(rngSelect1.Text)
Set rngSelect2 = ActiveDocument.Range(Start:=Cell2.Range.Start, End:=Cell2.Range.End - 1)
strBookmarkValue = Strip(rngSelect2.Text)
Set rng = ActiveDocument.Tables(intTableIndex).Cell(rngRowStart, rngColumnStart).Range
rng.End = rng.End - 1
'--------------------------------------------------------------------------
'tried and failed)
'--------------------------------------------------------------------------
'Stop
If ActiveDocument.Bookmarks.Exists(strBookmarkName) = True Then
ActiveDocument.Bookmarks(strBookmarkName).Delete
End If
If ActiveDocument.Bookmarks.Exists(strTstBookmark) = True Then
ActiveDocument.Bookmark(strTstBookmark).Delete
End If
ActiveDocument.Bookmarks.Add Name:=strTstBookmark
ActiveDocument.Bookmarks.Add Name:=strBookmarkName
ActiveDocument.Bookmarks(strBookmarkName).Range.Text = strBookmarkValue
Next intRow
'Next t
End Sub
'--------------------------------------------------------------------------
'tried and failed
Private Function Strip(ByVal fullest As String)
' fuller = Left(fullest, Len(s) - 2)
Strip = Trim(Replace(fullest, vbCr & Chr(7), ""))
End Function
'--------------------------------------------------------------------------
That's truly horrible code you're using. Try:
Sub BkMkDemo()
Application.ScreenUpdating = False
Dim r As Long, BkMkNm As String, BkMkTxt As String
With ActiveDocument
For r = 2 To .Tables(1).Rows.Count
BkMkNm = Split(.Tables(1).Cell(r, 1).Range.Text, vbCr)(0)
BkMkTxt = Split(.Tables(1).Cell(r, 2).Range.Text, vbCr)(0)
If Not .Bookmarks.Exists(BkMkNm) Then .Bookmarks.Add BkMkNm, .Range.Characters.Last
Call UpdateBookmark(BkMkNm, BkMkTxt)
Next
End With
Application.ScreenUpdating = True
End Sub
Sub UpdateBookmark(BkMkNm As String, BkMkTxt As String)
Dim BkMkRng As Range
With ActiveDocument
If .Bookmarks.Exists(BkMkNm) Then
Set BkMkRng = .Bookmarks(BkMkNm).Range
BkMkRng.Text = BkMkTxt
.Bookmarks.Add BkMkNm, BkMkRng
End If
End With
Set BkMkRng = Nothing
End Sub
If all you want to do is to apply the bookmark to the content of the second cell, you need nothing more complex than:
Sub BkMkDemo()
Application.ScreenUpdating = False
Dim r As Long, BkMkNm As String, BkMkRng As Range
With ActiveDocument
For r = 2 To .Tables(1).Rows.Count
BkMkNm = Split(.Tables(1).Cell(r, 1).Range.Text, vbCr)(0)
Set BkMkRng = .Tables(1).Cell(r, 2).Range
BkMkRng.End = BkMkRng.End - 1
.Bookmarks.Add BkMkNm, BkMkRng
Next
End With
Application.ScreenUpdating = True
End Sub
After a great deal of research and learning by this VBA neophyte, here is the solution that I finally got to work. I found the fix by accident on the Windows Dev Center at msdn dot microsoft dot com posted by Cindy Meister...thank you. Turns out there are a combination of three characters needing to be cleaned when extracting text from a Word table cell: Chr(10) & Chr(13), Chr(11).
I simplified the code using the suggestions of macropod above. Thank you.
Sub aBookmarkTable()
'
'a subroutine compiled by Steven McCrary from various sources
'on the Internet, to use values in the second column of the
'first table in a Word document to create Bookmarks in that second
'column, in place of the value input there.
'
'To use the macros, modify the values in the table and run the macro.
'Then place Field Code references in Word to use the Bookmarks.
'The Bookmarks can be seen through Word menu: Insert>Links>Bookmark
'
'The table has just two columns, looking something like this:
'_________________________________
'| bookmark_name | bookmark_value|
'| bm1 | 88 |
'| foo | 66 |
'|_____bar_______|______44_______|
'
'The code places each Bookmark in the second column of each row, using
'the name given in the first column.
'
'The two critical functions of the macro occur in these two lines of code:
' rngBM.End = rngBM.End - 1
' Strip = Replace(fullest, Chr(10) & Chr(13), Chr(11))
'
' both are explained below where they are used.
Application.ScreenUpdating = False
Dim rng1 As Range, rng2 As Range, rngBM As Range
Dim Cell_1 As Cell, Cell_2 As Cell
Dim strBMName As String, strBMValue As String
Dim r As Integer
Call RemoveBookmarks 'removing bookmarks helped to simlify the coding
With ActiveDocument
For r = 2 To .Tables(1).Rows.Count 'iterate through all rows
Set Cell_1 = ActiveDocument.Tables(1).Cell(r, 1)
Set Cell_2 = ActiveDocument.Tables(1).Cell(r, 2)
Cell_2.Select
Set rng1 = .Range(Cell_1.Range.Start, Cell_1.Range.End - 1)
strBMName = Strip(rng1.Text)
Set rng2 = .Range(Cell_2.Range.Start, Cell_2.Range.End - 1)
Set rngBM = ActiveDocument.Tables(1).Cell(r, 2).Range
'When using data contained in a cell of a Word table,
'grabbing the cell's contents also grabs several other
'characters, which therefore need removed in two steps.
'
'The first step is to clean the extra characters from the text.
strBMValue = Strip(rng2.Text)
'
'The second step is to decrease the range size to put in the
'Bookmark.
rngBM.End = rngBM.End - 1
rngBM.Text = strBMValue
.Bookmarks.Add strBMName, rngBM
Next r
End With
Application.ScreenUpdating = True
Selection.WholeStory
ActiveDocument.Fields.Update
End Sub
Sub RemoveBookmarks()
Dim bkm As Bookmark
For Each bkm In ActiveDocument.Bookmarks
bkm.Delete
Next bkm
End Sub
Private Function Strip(ByVal fullest As String)
' the next line of code is the tricky part of the clean
' process because of how Word formats tables and text
' ASCII code Chr(10) is Line Feed
' Chr(13) is Carriage Return
' Chr(13) + Chr(10): vbCrLf or vbNewLine New line character
' Chr (11) is Vertical Tab, but per Word VBA Manual -
' manual line break (Shift + Enter)
'
Strip = Replace(fullest, Chr(10) & Chr(13), Chr(11))
End Function
Thank you again.
SWM
I have a table with two rows that have conditional formating in them (rules like if lower than then colour text). I need to concatenate those two rows and preserve formatting from each row separately. Due to this I can't just concatenate values and paste formats as it will apply conditional formatting to the whole text and not just the parts of it.
I have searched for solution and found that you can convert conditional formatting to static formatting by using Range.DisplayFormat property. In my code I am basically going by each character
and copying DisplayFormat from source cell (with conditional formatting) and using the same font, size, bold and color on characters in my target range.
The result should look like this:
Unfortunately, I am getting just a concatenated string without formatting. Do you know a better way to achieve what I need? Or could you help me with fixing the existing code.
Sub Merge_Cells()
Dim i As Integer
Dim rngFrom1 As Range
Dim rngFrom2 As Range
Dim rngTo As Range
Dim lenFrom1 As Integer
Dim lenFrom2 As Integer
Set rngFrom1 = Cells(59, 1) 'first row
Set rngFrom2 = Cells(60, 1) 'second row
Set rngTo = Cells(64, 1)
lenFrom1 = Len(rngFrom1)
lenFrom2 = Len(rngFrom2)
rngTo.Value = rngFrom1.Text & " " & rngFrom2.Text 'concatenating text
For i = 1 To lenFrom1
With rngTo.Characters(i, 1).Font
.Name = rngFrom1.DisplayFormat.Characters(i, 1).Font.FontStyle
.Bold = rngFrom1.DisplayFormat.Characters(i, 1).Font.Bold
.Size = rngFrom1.DisplayFormat.Characters(i, 1).Font.Size
.ColorIndex = rngFrom1.DisplayFormat.Characters(i, 1).Font.ColorIndex
End With
Next i
For i = 1 To lenFrom2
'start from character that is after space
With rngTo.Characters(lenFrom1 + 1 + i, 1).Font
.Name = rngFrom2.DisplayFormat.Characters(i, 1).Font.Name
.Bold = rngFrom2.DisplayFormat.Characters(i, 1).Font.Bold
.Size = rngFrom2.DisplayFormat.Characters(i, 1).Font.Size
.ColorIndex = rngFrom2.DisplayFormat.Characters(i, 1).Font.ColorIndex
End With
Next i
End Sub
I have partly achieved what I wanted by copying my source range with all the conditional formatting to Word and pasting it back to Excel to another range. This way the formatting was preserved but there were no rules for conditional formatting and all the font parameters were readable by my macro. Only problem is when using non-standard colours as they are different in Excel and Word (for example red turns to pink)
Sub Merge_Cells()
Dim i As Integer
Dim rngFrom1 As Range
Dim rngFrom2 As Range
Dim rngTo As Range
Dim lenFrom1 As Integer
Dim lenFrom2 As Integer
Dim objWord As Object
Dim objDoc As Object
Dim rngcopy As Range
Dim ws As Worksheet
Set ws = Sheets("test")
ws.Visible = True
ws.Activate
Set rngcopy = Range("C51", "C53")
rngcopy.Select
' Copy Excel Selection
Selection.Copy
' Create new Word Application
Set objWord = CreateObject("Word.Application")
objWord.Visible = False
' Create new Word Document
Set objDoc = objWord.Documents.Add(Template:="Normal", NewTemplate:=False, DocumentType:=0)
' Paste Excel range into Word document
objWord.Selection.PasteExcelTable False, False, True
' Copy text from cells
If objDoc.Tables.Count >= 1 Then
objDoc.Tables(1).Select
objWord.Selection.Copy
End If
' Close Microsoft Word and not save changes
objWord.Quit False
Set objWord = Nothing
'Paste it back to Excel
ws.Range("C58").Activate
ws.Paste
'Old code
Set rngFrom1 = Cells(59, 3) 'first row
Set rngFrom2 = Cells(60, 3) 'second row
Set rngTo = Cells(64, 3)
lenFrom1 = Len(rngFrom1)
lenFrom2 = Len(rngFrom2)
rngTo.Value = rngFrom1.Text & " " & rngFrom2.Text 'concatenating text
For i = 1 To lenFrom1
With rngTo.Characters(i, 1).Font
.Name = rngFrom1.DisplayFormat.Characters(i, 1).Font.FontStyle
.Bold = rngFrom1.DisplayFormat.Characters(i, 1).Font.Bold
.Size = rngFrom1.DisplayFormat.Characters(i, 1).Font.Size
.ColorIndex = rngFrom1.DisplayFormat.Characters(i, 1).Font.ColorIndex
End With
Next i
For i = 1 To lenFrom2
'start from character that is after space
With rngTo.Characters(lenFrom1 + 1 + i, 1).Font
.Name = rngFrom2.DisplayFormat.Characters(i, 1).Font.Name
.Bold = rngFrom2.DisplayFormat.Characters(i, 1).Font.Bold
.Size = rngFrom2.DisplayFormat.Characters(i, 1).Font.Size
.ColorIndex = rngFrom2.DisplayFormat.Characters(i, 1).Font.ColorIndex
End With
Next i
End Sub
I need to call a word file from excel, and to create a template. Template will have 3 images UpperLeft, Upper Right and central image.
I thought that would be the best result do it through the table.
From some reason I can't create table from excel..
Private Sub CommandButton13_Click()
'Using early binding, not late-binding
Dim wsDoc As Word.Document
Dim wsApp As Word.Application
Dim wsRng As Word.Range
Dim wsTable as Word.Table
Dim intNoOfRows
Dim intNoOfColumns
Dim s As Word.InlineShape
Dim shp As Word.Shape
intNoOfRows = 4
intNoOfColumns = 2
Set wsApp = New Word.Application
wsApp.Visible = True
Set wsDoc = wsApp.Documents.Add
Set wsRange = wsDoc.Content
Set wsTable = wsDoc.Tables.Add(wsRange, intNoOfRows, intNoOfColumns)
wsTable.Borders.Enable = True
wsTable.Cell(1, 1).Range.InlineShapes.AddPicture _
UserForm1.txtImageLogoAdecco
wsTable.Cell(1, 2).Range.ParagraphFormat.Alignment = wdAlignParagraphRight
wsTable.Cell(1, 2).Range.InlineShapes.AddPicture _
UserForm1.txtImageLogoClient
Set wsRng = wsTable.Cell(2, 1).Range
With wsRng.Paragraphs.Add
wsTable.Cell(2, 1).Merge MergeTo:=wsTable.Cell(2, 2)
wsTable.Cell(2, 1).Height = 520
wsTable.Cell(2, 1).Range.Paragraphs.Add
wsTable.Cell(3, 1).Merge MergeTo:=objTable.Cell(3, 2)
wsTable.Cell(3, 1).Range.Text = "Prepared by:" & " " & UserForm1.txtPrepared
wsTable.Cell(4, 1).Merge MergeTo:=objTable.Cell(4, 2)
wsTable.Cell(4, 1).Range.ParagraphFormat.Alignment = wdAlignParagraphRight
wsTable.Cell(4, 1).Range.Text = "Belgrade," & " " & Format(Date, "MMMM DD, YYYY ")
Set wsRange = Nothing
Set wsTable = Nothing
Set wsDoc = Nothing
Set wsApp = Nothing
End Sub
Well, it's a bit clearer, but not completely. I've taken the liberty of editing your code so that it's correct, consistent and readable (without all the empty lines)!
I'll start with the part that is clear: << I want to move cursor a few lines down and to write some text. >>
To move the focus below a table, you get the table's range, then collapse it. For example:
Set wsRange = wsTable.Range
wsRange.Collapse wdCollapseEnd
'Now the range is in the paragraph following the table
wsRange.Text = "text following table"
"with background image I want to convert it to shape. I want to send iy behind the text"
This is the part that's not clear to me. Are you saying you want to insert one more image and position it behind the text? Use the Shapes.Add method and set the WrapFormat.Type to wdWrapBehind
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