由于我们使用的首字母缩略词和缩写词的数量，我经常需要在工作中和公司内部创建文档，我们几乎拥有自己的语言。因此，我厌倦了在我发布文档之前手动创建一个缩略语和缩写表，并且快速谷歌搜索遇到了一个宏，这将有效地为我做。 （修改后的代码如下所示）
我修改了这个宏，以便将表粘贴到原始文档中光标的位置（这可能不是msot的有效方式，但它是我能想到的最简单的因为我不是VBA专家）
从那时起，我意识到必须有一种简单的方法来通过自动包含定义来进一步加速这个过程。我有一个excel电子表格，第一列中包含Acronym，第二列中包含其定义。
到目前为止，我已经能够打开excel文档，但似乎无法获得将返回行号的搜索，因此使用它来将其旁边的定义单元格的内容复制到相应的定义中Word中表格的一部分。
**编辑 - 额外说明** 当前宏搜索word文档并查找已使用的所有首字母缩略词，并将它们放在单独的word文档中的表中。我想做的是让它然后搜索excel文件（预先存在）以找到每个找到的首字母缩略词的定义，并将它们也添加到表中，或者如果它们是新的，则将其留空。最后，宏将此表复制回原始文档。
此代码目前无法说.Find功能未定义？ （我现在保持代码分开以保持测试简单）
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
缩写词提取代码
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
答案 0 :(得分：2)
您错过了Worksheet Object
此外，With objExcel也可以省略，因为您已将Workbook Object传递给objWbk变量。
With objWbk.Sheets("NameOfYourSheet")
Set rngSearch = .Range(.Range("A1"), .Range("A" & .Rows.Count).End(xlUp))
Set rngFound = rngSearch.Find(What:="AS345", After:=.Range("A1"), LookAt:=xlWhole)
If rngFound Is Nothing Then
MsgBox "Not found"
Else
MsgBox rngFound.Row
End If
End With
在上面的代码中，我假设你的Excel数据有标题。
编辑1：由于您是Late Binding Excel，这应该有效：
With objWbk.Sheets("Sheet1")
Set rngSearch = .Range(.Range("A1"), .Range("A" & .Rows.Count).End(-4162))
Set rngFound = rngSearch.Find(What:="AS345", After:=.Range("A1"), LookAt:=1)
If rngFound Is Nothing Then
MsgBox "Not found"
Else
MsgBox rngFound.Row
End If
End With
请注意，我们已将xlUp替换为等效常量-4162，将xlWhole替换为1。
要了解有关早期和晚期绑定的更多信息，请查看THIS
有关其他信息，您还可以参考HERE。
虽然在我提供的链接中有讨论，但您可能会问我在哪里获得常数？
只需打开Excel或您绑定的任何其他MS应用程序，然后查看Immediate Window - Ctrl + G
在即时窗口中，键入?，然后键入要获得等效数字的常量
示例：
?xlUp
-4162
?xlWhole
1
?xlPart
2
希望以某种方式解决你的问题。
答案 1 :(得分：1)
因此，通过一些搜索，我会找到问题的解决方案。非常感谢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
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
**编辑，完整的代码搜索和查找首字母缩略词及其定义**
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