自动Excel首字母缩写查找和定义添加
我经常需要在工作和公司内部创build文件，因为我们使用的首字母缩略词和缩写词的数量，我们几乎都有自己的语言。 因此，在我发布文档之前，我已经厌倦了手动创buildAcronym和缩写表，并且快速的Googlesearch遇到了一个可以为我实现的macros。 （修改后的代码如下）
我修改了这个macros，以便将表格粘贴到原始文档中的游标位置（这可能不是msot有效的方式，但这是我可以想象的最简单的，因为我不是VBA专家）。
从那以后，我意识到必须有一个简单的方法，通过自动包含定义来进一步加快这个过程。 我有一个Excel电子表格，第一列中的首字母缩略词和第二列中的定义。
到目前为止，我已经能够打开excel文档，但似乎无法得到一个将返回行号的search，因此用它来复制旁边的定义单元格的内容到相应的定义部分在Word中的表。
**编辑 – 额外说明**当前macrossearch单词文档，并find所有已使用的缩写词，并将它们放在一个单独的文档中的表中。 我想要做的是，然后search一个Excel文件（预先存在），以find每个find的缩略词的定义，并将它们也添加到表中，或者如果它们是新的，则保留空白。 最后macros把这个表复制回原来的文档。
此代码目前失败，说.Find函数没有定义？ （我已经保持代码分开，以保持简单的testing）
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 eg 2 or more letters, 'change 3 to 2 in the line below .Text = "<[AZ]{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
您只是缺lessWorksheet Object 。
另外，由于您已经将Workbook Object传递给objWbkvariables，因此可以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
请注意，我们用它的当量常数-4162代替xlUp ，用1代替xlUp 。
要了解有关早期和晚期绑定的更多信息，请检查此 。
有关更多信息，您也可以参考这里 。
虽然它在我提供的链接中有所讨论，但你可能会问我在哪里得到常数？
只需打开Excel或任何其他绑定的MS应用程序，然后查看Immediate Window – Ctrl + G
在即时窗口中，input? 那么你想得到的数字相当于常数。
例：
?xlUp -4162 ?xlWhole 1 ?xlPart 2
希望这可以解决你的问题。
所以它会出现一些search我发现问题的解决scheme。 非常感谢L42帮助解决了我是使用早期还是晚期的问题（我甚至不知道这些问题甚至不同）。
发生以下错误的其余问题：
编译错误：找不到名称的参数
一旦我find解决scheme，是令人惊讶的容易解决…你必须爱后视。 事实certificate，我必须将我的两个variablesrngFound和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
**编辑，完整的代码search和find首字母缩写词及其定义**
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 eg 2 or more letters, 'change 3 to 2 in the line below .Text = "<[AZ][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