自动Excel首字母缩略词查找和定义添加 [英] Automatic Excel Acronym finding and Definition adding
本文介绍了自动Excel首字母缩略词查找和定义添加的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！
问题描述
我修改了这个宏，以便将表粘贴到原始文档中光标的位置（这可能不是msot有效的方式，但是我可以想到的最简单，我不是VBA专家）。
从那时起，我意识到必须有一个简单的方法来进一步加快此过程也自动包括定义。我有一个excel电子表格与第一列的首字母缩略词及其定义在第二列。
到目前为止，我已经能够打开Excel文档，但似乎无法获得一个返回行号的搜索，因此使用它来复制将其定义单元格的内容放入Word中表格的相应定义部分。
**编辑 - 额外说明**
当前宏搜索单词文档并查找已使用的所有首字母缩略词，并将它们放在单独的单词文档中的表中。我想做的是让它还搜索一个excel文件（预先存在的）来定义每个找到的首字母缩略词，并将它们添加到表中，或者如果它们是新的，则将其留空。最后，宏将此表复制回原始文档。
此代码当前失败，表示.Find函数未定义？ （我现在保持代码分开来保持测试简单）
Dim objExcel As Object
Dim objWbk As Object
Dim objDoc As Document
Dim rngSearch As Range
Dim rngFound As Range
设置objDoc = ActiveDocument
设置objExcel = CreateObject（ Excel.Application）
设置objWbk = objExcel.Workbooks.Open（P：\ENGINEERING\EL\Global Access\Abbreviations and Acronyms.xls）
objExcel.Visible = True
objWbk.Activate
带objExcel
带objWbk
设置rngSearch = objWbk.Range（A：A）
设置rngFound = rngSearch.Find什么：=AS345，LookIn：= xlValues，LookAt：= xlPart）
如果rngFound不是，然后
MsgBox未找到
Else
MsgBox rngFound .Row
如果
结束
结束
Err_Exit：
'清理
设置BMRange = Nothing
Set objWbk = Nothing
objExcel.Visible = True
Set objExcel = Nothing
Set objDoc = Nothing
'Ms gBox该文档已被更新
Err_Handle：
如果Err.Number = 429然后'excel不运行;启动Excel
设置objExcel = CreateObject（Excel.Application）
恢复下一个
ElseIf Err.Number<> 0然后
MsgBoxError&错误编号& ：& Err.Description
简历Err_Exit
如果
End Sub
$ b $首字母缩略词提取代码
Sub ExtractACRONYMSToNewDocument（）
'====== ===================
'宏创建2008年由Lene Fredborg，DocTools - www.thedoctools.com
'这个版权是版权。你很高兴使用宏，但你必须保持上述的线。
'您不可以将自己作为您自己，全部或部分发布。
'=========================
'由David Mason于2014年修改，将首字母缩写表放在原始文件中
'=======================
Dim oDoc_Source As Document
Dim oDoc_Target As Document
Dim strListSep As String
Dim strAcronym As String
Dim strDef As String
Dim oTable As Table
Dim oRange As Range
Dim n As Long
Dim strAllFound As String
Dim Title As String
Dim Msg As String
Title =Extract Acronyms to New Document
'显示msg - 停止，如果用户没有单击是
Msg =此宏查找所有由3个或更多的组成& _
大写字母，并将单词提取到表& _
在一个新的文档中，您可以添加定义。 &安培; vbCr& vbCr& _
你想继续吗？
如果MsgBox（Msg，vbYesNo + vbQuestion，Title）< vbYes然后
退出Sub
结束如果
Application.ScreenUpdating = False
'从国际设置中查找列表分隔符
'可能是根据国家/地区的逗号或分号
strListSep = Application.International（wdListSeparator）
'开始一个字符串，用于存储找到的首字母缩略词的名称
strAllFound =＃
设置oDoc_Source = ActiveDocument
'为首字母缩略词创建新文档
设置oDoc_Target = Documents.Add
带有oDoc_Target
'确保文档是空的
.Range =
'插入信息在头 - 更改日期格式，如果你想要
'.PageSetup.TopMargin = CentimetersToPoints（3）
'.Sections（1）.Headers（wdHeaderFooterPrimary）.Range.Text = _
'从：& oDoc_Source.FullName& vbCr& _
'创建人：& Application.UserName& vbCr& _
'创建日期：&格式（日期，MMMM d，yyyy）
'调整正常样式和标题样式
使用.Styles（wdStyleNormal）
.Font.Name =Arial
.Font.Size = 10
.ParagraphFormat.LeftIndent = 0
.ParagraphFormat.SpaceAfter = 6
结束
带.Styles（wdStyleHeader）
.Font.Size = 8
.ParagraphFormat.SpaceAfter = 0
结束
'插入带有缩写和定义空间的表
设置oTable = .Tables.Add（Range：=。Range，NumRows：= 2，NumColumns：= 2）
带有oTable
'格式化表
'插入标题
.Range .Style = wdStyleNormal
.AllowAutoFit = False
.Cell（1，1）.Range.Text =首字母缩略词
.Cell（1，2）.Range.Text =定义
'.Cell（1，3）.Range.Text =Page
'将行设置为标题行
.Rows（1）.HeadingFormat = True
。罗斯（1 ）.Range.Font.Bold = True
.PreferredWidthType = wdPreferredWidthPercent
.Columns（1）.PreferredWidth = 20
.Columns（2）.PreferredWidth = 70
'.Columns （3）.PreferredWidth = 10
结束
结束
与oDoc_Source
设置oRange = .Range
n = 1'used计数低于
使用oRange.Find
'使用通配符搜索查找由3个或更多大写字母组成的字符串
'设置搜索条件
'注意：如果你想要找到例如缩略语2个或更多个字母，
'更改3到2在
.Text =< [A-Z] {3& strListSep& }> 中
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = True
.MatchWildcards = True
'执行搜索
Do While .Execute
'继续找到
strAcronym = oRange
'插入目标文档
'如果strAcronym已经在strAllFound中，不要再添加
如果InStr（1，strAllFound，＃& strAcronym&＃）= 0然后
'从第二个首字母缩写
添加表中的新行如果n& ; 1然后oTable.Rows.Add
'在
之前找不到strAllFound = strAllFound& strAcronym& ＃
'在oTable
'中插入列1 $补偿标题列
带有oTable
.Cell（n + 1，1）.Range.Text = strAcronym
'在第3列中插入页码
'.Cell（n + 1，3）.Range.Text = oRange.Information（wdActiveEndPageNumber）
结束
n = n + 1
结束如果
循环
结束
结束
'按字母顺序排序首字母缩略词 - 如果只找到1，则跳过
如果n> 2然后
与选择
.Sort ExcludeHeader：= True，FieldNumber：=列1，SortFieldType _
：= wdSortFieldAlphanumeric，SortOrder：= wdSortOrderAscending
'转到文档
.HomeKey（wdStory）
结束与
结束如果
'复制整个表，切换到源文件和过去
'在原始选择位置的表中
Selection.WholeStory
Selection.Copy
oDoc_Source.Activate
Selection.Paste
'使目标文档处于活动状态并将其关闭而不保存
oDoc_Target.Activate
ActiveDocument.Close SaveChanges：= wdDoNotSaveChanges
Application.ScreenUpdating = True
'如果没有找到首字母缩略词，显示msg并关闭新文档而不保存
'否则保持打开
如果n = 1然后
Msg =没有找到首字母缩略词。
oDoc_Target.Close SaveChanges：= wdDoNotSaveChanges
Else
Msg =完成提取& n-1& 一个新的文件的缩写词。
End If
MsgBox Msg，vbOKOnly，Title
'清理
设置oRange = Nothing
设置oDoc_Source =没有
设置oDoc_Target = Nothing
设置oTable = Nothing
End Sub
解决方案
所以看起来我会找到解决问题的方法。很感谢L42谁帮助解决了我是否使用早期或晚期绑定（我不知道这些甚至是不同）的问题。
发生以下错误的其他问题：
编译错误：命名没有找到参数
一旦我找到解决方案，就会很容易解决...你必须喜欢后见之明。原来我不得不将我的两个变量rngFound和rngSearch定义为对象。一旦我做了这个改变，代码工作很好。
这是我将在我的缩写宏中加入的工作代码。 （完成后将添加总代码）
Sub openExcel（）
Dim objExcel As Object
Dim objWbk As Object
Dim objDoc As Document
Dim rngSearch As Object
Dim rngFound As Object
Dim targetCellValue
Set objDoc = ActiveDocument
设置objExcel = CreateObject（Excel.Application）
设置objWbk = objExcel.Workbooks.Open（C：\Users\DMASON2\Documents\Book1.xlsx）
objExcel.Visible = True
objWbk.Activate
使用objWbk.Sheets（Sheet1）
设置rngSearch = .Range（.Range（A1），.Range A& .Rows.Count）.End（-4162））
设置rngFound = rngSearch.Find（什么：=AA，之后：=。范围（A1），LookAt：= 1 ）
如果rngFound不是，然后
MsgBoxNot found
Else
'MsgBox rngFound.Row
targetCellValue = .Cells（rngFound.Row，2）.Value
MsgBox（targetCellValue）
End If
End With
Err_Exit：
'清理
设置BMRange =没有
设置objWbk =没有
objExcel.Visible = True
设置objExcel =没有
设置objDoc =没有
'MsgBox文档已经更新
Err_Handle：
如果Err.Number = 429然后'excel不运行;启动Excel
设置objExcel = CreateObject（Excel.Application）
恢复下一个
ElseIf Err.Number<> 0然后
MsgBoxError&错误编号& ：& Err.Description
简历Err_Exit
如果
End Sub
**编辑，完整的代码搜索和查找缩略语及其定义**
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
'设置消息框消息
Msg =此宏找到所有首字母缩略词（由2个或更多的& _
大写字母，数字或'/'组成）和thei r相关定义。然后将& _
提取到您选择的当前位置的表格中的单词& vbCr& vbCr& _
警告 - 请确保您手动检查表格
'显示消息框
如果MsgBox（Msg，vbYesNo + vbQuestion，Title），则
<> vbYes然后
退出子
结束如果
'停止屏幕更新
Application.ScreenUpdating = False
'从国际设置中查找列表分隔符
'根据国家/地区可能是逗号或分号
strListSep = Application.International（wdListSeparator）
'启动一个字符串用于存储找到缩写词的名称
strAllFound =＃
'给活动文档一个变量
设置oDoc_Source = ActiveDocument
' Crete一个用于excel的变量并打开定义工作簿
设置objExcel = CreateObject（Excel.Application）
设置obj Wbk = objExcel.Workbooks.Open（C：\Users\Dave\Documents\Test_Definitions.xlsx）
'objExcel.Visible = True
objWbk.Activate
'创建新文档以临时存储首字母缩略词
设置oDoc_Target = Documents.Add
'使用目标文档
与oDoc_Target
'Make确定文档是空的
.Range =
'插入信息在标题 - 更改日期格式，如果你想要
'.PageSetup.TopMargin = CentimetersToPoints（3）
'.Sections（1）.Headers（wdHeaderFooterPrimary）.Range.Text = _
'从：& oDoc_Source.FullName& vbCr& _
'创建人：& Application.UserName& vbCr& _
'创建日期：&格式（日期，MMMM d，yyyy）
'调整正常样式和标题样式
使用.Styles（wdStyleNormal）
.Font.Name =Arial
.Font.Size = 10
.ParagraphFormat.LeftIndent = 0
.ParagraphFormat.SpaceAfter = 6
结束
带.Styles（wdStyleHeader）
.Font.Size = 8
.ParagraphFormat.SpaceAfter = 0
结束
'插入带有缩写和定义空间的表
设置oTable = .Tables.Add（Range：=。Range，NumRows：= 2，NumColumns：= 2）
带有oTable
'格式化表
'插入标题
.Range .Style = wdStyleNormal
.AllowAutoFit = False
.Cell（1，1）.Range.Text =首字母缩略词
.Cell（1，2）.Range.Text =定义
'将行设为标题行
.Rows（1）.HeadingFormat = True
.Rows（1）.Range.Font.Bold = True
。优先WidthType = wdPreferredWidthPercent
.Columns（1）.PreferredWidth = 20
.Columns（2）.PreferredWidth = 70
结束
结束
与oDoc_Source
设置oRange = .Range
n = 1'用于计算总数范围内的
'的源文件
使用oRange.Find
'使用通配符搜索来查找由3个或更多大写字母组成的字符串
'设置搜索条件
'注意：如果要找到缩略语例如2个或更多个字母，
'在
.Text =< [A-Z] [A-Z0-9 /] {1& strListSep& }> 中
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = True
.MatchWildcards = True
'执行搜索
Do While .Execute
'继续找到
strAcronym = oRange
'插入目标文档
'如果strAcronym是已经在strAllFound中，不要再添加
如果InStr（1，strAllFound，＃& strAcronym&＃）= 0然后
'从第二个表中添加新行首字母缩略词
如果n> 1然后oTable.Rows.Add
'在
之前找不到strAllFound = strAllFound& strAcronym& ＃
'在第1列中插入oTable
'补偿标题行
带有oTable
.Cell（n + 1，1） .Range.Text = strAcronym
'从Excel文档中查找定义
使用objWbk.Sheets（Sheet1）
'使用Excel中的数据查找单元格的范围doc
设置rngSearch = .Range（.Range（A1），.Range（A& .Rows.Count）.End（-4162））
'搜索
的找到范围设置rngFound = rngSearch.Find（What：= strAcronym，After：=。Range（A1），LookAt：= 1）
'如果没有找到计算没有定义的首字母缩略词的数量
如果rngFound Is Nothing然后
m = m + 1
'将单元格变量设置为新表格为空白
targetCellValue =
'如果找到定义，将其输入到单元格变量
Else
targetCellValue = .Cells（rngFound.Row ，2）.Value
End If
End With
'将单元格varibale输入到定义单元格
.Cell（n + 1，2 ）.Range.Text = targetCellValue
结束
'添加一个循环计数
n = n + 1
结束If
循环
结束
结束
'按字母顺序排序首字母缩写 - 如果只找到1，则跳过
如果n > 2然后
选择
.Sort ExcludeHeader：= True，FieldNumber：=Column 1，SortFieldType _
：= wdSortFieldAlphanumeric，SortOrder = = wdSortOrderAscending
'转到文档
.HomeKey（wdStory）
结束
结束如果
'复制整个表，切换到源文件和过去
'在原始选择位置的表中
Selection.WholeStory
Selection.Copy
oDoc_Source.Activate
Selection.Paste
'更新屏幕
Application.ScreenUpdating = True
'如果没有首字母缩略词找到设置消息说如此
如果n = 1然后
Msg =否首字母缩略词。
'设置最终消息框消息以显示找到的首字母缩略词数量和没有定义的数量
Else
Msg =完成提取& n-1& acronymn（s）to a new document。无法找到& m& 首字母缩略词。
End If
'显示完成的消息框
AppActivate Application.Caption
MsgBox Msg，vbOKOnly，Title
'make the target文档处于活动状态并关闭它，而不保存
oDoc_Target.Activate
ActiveDocument.Close SaveChanges：= wdDoNotSaveChanges
'关闭Excel后
objWbk.Close Saved = True
'清理
设置oRange = Nothing
设置oDoc_Source =没有
设置oDoc_Target =没有
设置oTable = Nothing
设置objExcel = Nothing
Set objWbk = Nothing
End Sub
I regularly have to create documents at work and within the company we almost have a language of our own due to the number of acronyms and abbreviations we use. Consequently I got tired of manually creating an Acronym and abbreviation table before I could publish the document and a quick google search came across a macro that would effectively do it for me. (modified code shown below)
I modified this macro so that the table was pasted into the location of the cursor in the original document (this may not be the msot efficient way, but it was the simplest i could think of as I am not a VBA expert).
Since then I have realised that there must be a simple way to further speed up this process by automatically including the definitions as well. I have an excel spreadsheet with the Acronym in the first column and its definition in the second.
So far I have been able to get as far as opening the excel document but cannot seem to get a search which will return the row number and consequently use this to copy the contents of the definition cell next to it into the corresponding definition section of the table in Word.
** edit - extra explanation ** The current macro searches the word document and finds all the acronyms that have been used and places them in a table in a seperate word document. What i wish to do is have it also then search an excel file (pre-existing) for the definition of each of the found acronyms and add them also to the table or if they are new leave it blank. Finally the macro copies this table back into the original document.
This code currently fails saying the .Find function is not defined? (I have kept the code seperate for now to keep testing simple)
Dim objExcel As Object
Dim objWbk As Object
Dim objDoc As Document
Dim rngSearch As Range
Dim rngFound As Range
Set objDoc = ActiveDocument
Set objExcel = CreateObject("Excel.Application")
Set objWbk = objExcel.Workbooks.Open("P:\ENGINEERING\EL\Global Access\Abbreviations and Acronyms.xls")
objExcel.Visible = True
objWbk.Activate
With objExcel
With objWbk
Set rngSearch = objWbk.Range("A:A")
Set rngFound = rngSearch.Find(What:="AS345", LookIn:=xlValues, LookAt:=xlPart)
If rngFound Is Nothing Then
MsgBox "Not found"
Else
MsgBox rngFound.Row
End If
End With
End With
Err_Exit:
'clean up
Set BMRange = Nothing
Set objWbk = Nothing
objExcel.Visible = True
Set objExcel = Nothing
Set objDoc = Nothing
'MsgBox "The document has been updated"
Err_Handle:
If Err.Number = 429 Then 'excel not running; launch Excel
Set objExcel = CreateObject("Excel.Application")
Resume Next
ElseIf Err.Number <> 0 Then
MsgBox "Error " & Err.Number & ": " & Err.Description
Resume Err_Exit
End If
End Sub
Acronym extraction code
Sub ExtractACRONYMSToNewDocument()
'=========================
'Macro created 2008 by Lene Fredborg, DocTools - www.thedoctools.com
'THIS MACRO IS COPYRIGHT. YOU ARE WELCOME TO USE THE MACRO BUT YOU MUST KEEP THE LINE ABOVE.
'YOU ARE NOT ALLOWED TO PUBLISH THE MACRO AS YOUR OWN, IN WHOLE OR IN PART.
'=========================
'Modified in 2014 by David Mason to place the acronym table in the original document
'=========================
Dim oDoc_Source As Document
Dim oDoc_Target As Document
Dim strListSep As String
Dim strAcronym As String
Dim strDef As String
Dim oTable As Table
Dim oRange As Range
Dim n As Long
Dim strAllFound As String
Dim Title As String
Dim Msg As String
Title = "Extract Acronyms to New Document"
'Show msg - stop if user does not click Yes
Msg = "This macro finds all words consisting of 3 or more " & _
"uppercase letters and extracts the words to a table " & _
"in a new document where you can add definitions." & vbCr & vbCr & _
"Do you want to continue?"
If MsgBox(Msg, vbYesNo + vbQuestion, Title) <> vbYes Then
Exit Sub
End If
Application.ScreenUpdating = False
'Find the list separator from international settings
'May be a comma or semicolon depending on the country
strListSep = Application.International(wdListSeparator)
'Start a string to be used for storing names of acronyms found
strAllFound = "#"
Set oDoc_Source = ActiveDocument
'Create new document for acronyms
Set oDoc_Target = Documents.Add
With oDoc_Target
'Make sure document is empty
.Range = ""
'Insert info in header - change date format as you wish
'.PageSetup.TopMargin = CentimetersToPoints(3)
'.Sections(1).Headers(wdHeaderFooterPrimary).Range.Text = _
' "Acronyms extracted from: " & oDoc_Source.FullName & vbCr & _
' "Created by: " & Application.UserName & vbCr & _
' "Creation date: " & Format(Date, "MMMM d, yyyy")
'Adjust the Normal style and Header style
With .Styles(wdStyleNormal)
.Font.Name = "Arial"
.Font.Size = 10
.ParagraphFormat.LeftIndent = 0
.ParagraphFormat.SpaceAfter = 6
End With
With .Styles(wdStyleHeader)
.Font.Size = 8
.ParagraphFormat.SpaceAfter = 0
End With
'Insert a table with room for acronym and definition
Set oTable = .Tables.Add(Range:=.Range, NumRows:=2, NumColumns:=2)
With oTable
'Format the table a bit
'Insert headings
.Range.Style = wdStyleNormal
.AllowAutoFit = False
.Cell(1, 1).Range.Text = "Acronym"
.Cell(1, 2).Range.Text = "Definition"
'.Cell(1, 3).Range.Text = "Page"
'Set row as heading row
.Rows(1).HeadingFormat = True
.Rows(1).Range.Font.Bold = True
.PreferredWidthType = wdPreferredWidthPercent
.Columns(1).PreferredWidth = 20
.Columns(2).PreferredWidth = 70
'.Columns(3).PreferredWidth = 10
End With
End With
With oDoc_Source
Set oRange = .Range
n = 1 'used to count below
With oRange.Find
'Use wildcard search to find strings consisting of 3 or more uppercase letters
'Set the search conditions
'NOTE: If you want to find acronyms with e.g. 2 or more letters,
'change 3 to 2 in the line below
.Text = "<[A-Z]{3" & strListSep & "}>"
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = True
.MatchWildcards = True
'Perform the search
Do While .Execute
'Continue while found
strAcronym = oRange
'Insert in target doc
'If strAcronym is already in strAllFound, do not add again
If InStr(1, strAllFound, "#" & strAcronym & "#") = 0 Then
'Add new row in table from second acronym
If n > 1 Then oTable.Rows.Add
'Was not found before
strAllFound = strAllFound & strAcronym & "#"
'Insert in column 1 in oTable
'Compensate for heading row
With oTable
.Cell(n + 1, 1).Range.Text = strAcronym
'Insert page number in column 3
'.Cell(n + 1, 3).Range.Text = oRange.Information(wdActiveEndPageNumber)
End With
n = n + 1
End If
Loop
End With
End With
'Sort the acronyms alphabetically - skip if only 1 found
If n > 2 Then
With Selection
.Sort ExcludeHeader:=True, FieldNumber:="Column 1", SortFieldType _
:=wdSortFieldAlphanumeric, SortOrder:=wdSortOrderAscending
'Go to start of document
.HomeKey (wdStory)
End With
End If
'Copy the whole table, switch to the source document and past
'in the table at the original selection location
Selection.WholeStory
Selection.Copy
oDoc_Source.Activate
Selection.Paste
'make the target document active and close it down without saving
oDoc_Target.Activate
ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
Application.ScreenUpdating = True
'If no acronyms found, show msg and close new document without saving
'Else keep open
If n = 1 Then
Msg = "No acronyms found."
oDoc_Target.Close SaveChanges:=wdDoNotSaveChanges
Else
Msg = "Finished extracting " & n - 1 & " acronymn(s) to a new document."
End If
MsgBox Msg, vbOKOnly, Title
'Clean up
Set oRange = Nothing
Set oDoc_Source = Nothing
Set oDoc_Target = Nothing
Set oTable = Nothing
End Sub
解决方案
So it would appear with some searching I found the solution to the problem. A big thank you to L42 who helped solve the problem regarding whether i was using Early or Late binding (I had no idea these were even different).
The remaining problem where the following error occured:
Compile Error: Named Argument not found
Was suprisingly easy to solve once I found the solution... you have to love hindsight. It turns out I had to define my two variables rngFound and rngSearch as objects. As soon as i made that change the code worked beautifully.
Here is the working code which I will then incorporate into my acronym macro. (will add the total code when complete)
Sub openExcel()
Dim objExcel As Object
Dim objWbk As Object
Dim objDoc As Document
Dim rngSearch As Object
Dim rngFound As Object
Dim targetCellValue
Set objDoc = ActiveDocument
Set objExcel = CreateObject("Excel.Application")
Set objWbk = objExcel.Workbooks.Open("C:\Users\DMASON2\Documents\Book1.xlsx")
objExcel.Visible = True
objWbk.Activate
With objWbk.Sheets("Sheet1")
Set rngSearch = .Range(.Range("A1"), .Range("A" & .Rows.Count).End(-4162))
Set rngFound = rngSearch.Find(What:="AA", After:=.Range("A1"), LookAt:=1)
If rngFound Is Nothing Then
MsgBox "Not found"
Else
'MsgBox rngFound.Row
targetCellValue = .Cells(rngFound.Row, 2).Value
MsgBox (targetCellValue)
End If
End With
Err_Exit:
'clean up
Set BMRange = Nothing
Set objWbk = Nothing
objExcel.Visible = True
Set objExcel = Nothing
Set objDoc = Nothing
'MsgBox "The document has been updated"
Err_Handle:
If Err.Number = 429 Then 'excel not running; launch Excel
Set objExcel = CreateObject("Excel.Application")
Resume Next
ElseIf Err.Number <> 0 Then
MsgBox "Error " & Err.Number & ": " & Err.Description
Resume Err_Exit
End If
End Sub
** edit, complete code for searching and finding the acronyms along with their definitions **
Sub ExtractACRONYMSToNewDocument()
Dim oDoc_Source As Document
Dim oDoc_Target As Document
Dim strListSep As String
Dim strAcronym As String
Dim strDef As String
Dim oTable As Table
Dim oRange As Range
Dim n As Long
Dim m As Long
m = 0
Dim strAllFound As String
Dim Title As String
Dim Msg As String
Dim objExcel As Object
Dim objWbk As Object
Dim rngSearch As Object
Dim rngFound As Object
Dim targetCellValue As String
' message box title
Title = "Extract Acronyms to New Document"
' Set message box message
Msg = "This macro finds all Acronyms (consisting of 2 or more " & _
"uppercase letters, Numbers or '/') and their associated definitions. It " & _
"then extracts the words to a table at the current location you have selected" & vbCr & vbCr & _
"Warning - Please make sure you check the table manually after!" & vbCr & vbCr & _
"Do you want to continue?"
' Display message box
If MsgBox(Msg, vbYesNo + vbQuestion, Title) <> vbYes Then
Exit Sub
End If
' Stop the screen from updating
Application.ScreenUpdating = False
'Find the list separator from international settings
'May be a comma or semicolon depending on the country
strListSep = Application.International(wdListSeparator)
'Start a string to be used for storing names of acronyms found
strAllFound = "#"
' give the active document a variable
Set oDoc_Source = ActiveDocument
'Crete a variable for excel and open the definition workbook
Set objExcel = CreateObject("Excel.Application")
Set objWbk = objExcel.Workbooks.Open("C:\Users\Dave\Documents\Test_Definitions.xlsx")
'objExcel.Visible = True
objWbk.Activate
'Create new document to temporarily store the acronyms
Set oDoc_Target = Documents.Add
' Use the target document
With oDoc_Target
'Make sure document is empty
.Range = ""
'Insert info in header - change date format as you wish
'.PageSetup.TopMargin = CentimetersToPoints(3)
'.Sections(1).Headers(wdHeaderFooterPrimary).Range.Text = _
' "Acronyms extracted from: " & oDoc_Source.FullName & vbCr & _
' "Created by: " & Application.UserName & vbCr & _
' "Creation date: " & Format(Date, "MMMM d, yyyy")
'Adjust the Normal style and Header style
With .Styles(wdStyleNormal)
.Font.Name = "Arial"
.Font.Size = 10
.ParagraphFormat.LeftIndent = 0
.ParagraphFormat.SpaceAfter = 6
End With
With .Styles(wdStyleHeader)
.Font.Size = 8
.ParagraphFormat.SpaceAfter = 0
End With
'Insert a table with room for acronym and definition
Set oTable = .Tables.Add(Range:=.Range, NumRows:=2, NumColumns:=2)
With oTable
'Format the table a bit
'Insert headings
.Range.Style = wdStyleNormal
.AllowAutoFit = False
.Cell(1, 1).Range.Text = "Acronym"
.Cell(1, 2).Range.Text = "Definition"
'Set row as heading row
.Rows(1).HeadingFormat = True
.Rows(1).Range.Font.Bold = True
.PreferredWidthType = wdPreferredWidthPercent
.Columns(1).PreferredWidth = 20
.Columns(2).PreferredWidth = 70
End With
End With
With oDoc_Source
Set oRange = .Range
n = 1 'used to count below
' within the total range of the source document
With oRange.Find
'Use wildcard search to find strings consisting of 3 or more uppercase letters
'Set the search conditions
'NOTE: If you want to find acronyms with e.g. 2 or more letters,
'change 3 to 2 in the line below
.Text = "<[A-Z][A-Z0-9/]{1" & strListSep & "}>"
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = True
.MatchWildcards = True
'Perform the search
Do While .Execute
'Continue while found
strAcronym = oRange
'Insert in target doc
'If strAcronym is already in strAllFound, do not add again
If InStr(1, strAllFound, "#" & strAcronym & "#") = 0 Then
'Add new row in table from second acronym
If n > 1 Then oTable.Rows.Add
'Was not found before
strAllFound = strAllFound & strAcronym & "#"
'Insert in column 1 in oTable
'Compensate for heading row
With oTable
.Cell(n + 1, 1).Range.Text = strAcronym
' Find the definition from the Excel document
With objWbk.Sheets("Sheet1")
' Find the range of the cells with data in Excel doc
Set rngSearch = .Range(.Range("A1"), .Range("A" & .Rows.Count).End(-4162))
' Search in the found range for the
Set rngFound = rngSearch.Find(What:=strAcronym, After:=.Range("A1"), LookAt:=1)
' if nothing is found count the number of acronyms without definitions
If rngFound Is Nothing Then
m = m + 1
' Set the cell variable in the new table as blank
targetCellValue = ""
' If a definition is found enter it into the cell variable
Else
targetCellValue = .Cells(rngFound.Row, 2).Value
End If
End With
' enter the cell varibale into the definition cell
.Cell(n + 1, 2).Range.Text = targetCellValue
End With
' add one to the loop count
n = n + 1
End If
Loop
End With
End With
'Sort the acronyms alphabetically - skip if only 1 found
If n > 2 Then
With Selection
.Sort ExcludeHeader:=True, FieldNumber:="Column 1", SortFieldType _
:=wdSortFieldAlphanumeric, SortOrder:=wdSortOrderAscending
'Go to start of document
.HomeKey (wdStory)
End With
End If
'Copy the whole table, switch to the source document and past
'in the table at the original selection location
Selection.WholeStory
Selection.Copy
oDoc_Source.Activate
Selection.Paste
' update screen
Application.ScreenUpdating = True
'If no acronyms found set message saying so
If n = 1 Then
Msg = "No acronyms found."
' set the final messagebox message to show the number of acronyms found and those that did not have definitions
Else
Msg = "Finished extracting " & n - 1 & " acronymn(s) to a new document. Unable to find definitions for " & m & " acronyms."
End If
' Show the finished message box
AppActivate Application.Caption
MsgBox Msg, vbOKOnly, Title
'make the target document active and close it down without saving
oDoc_Target.Activate
ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
'Close Excel after
objWbk.Close Saved = True
'Clean up
Set oRange = Nothing
Set oDoc_Source = Nothing
Set oDoc_Target = Nothing
Set oTable = Nothing
Set objExcel = Nothing
Set objWbk = Nothing
End Sub
这篇关于自动Excel首字母缩略词查找和定义添加的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
查看全文
