自动Excel首字母缩写查找，定义和分类添加

我一直在使用我在这里find的代码，但是我很难让它为我做更多的任务。 我已经添加了另一列（3）到我的首字母缩略词文件，其中有首字母缩略词和定义的“分类”，我想把它添加到第1列中的新创build的单词首字母缩写之前。 我尝试了几种不同的方式来移动提供的代码，但总是会导致错误。 任何帮助表示赞赏。 我已经包含了下面的工作代码。 就像我说的那样，我只想让它做更多的事情。 谢谢！

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 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(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 

Answer 1

如果有人正在寻找这个解决scheme，我可以通过复制以下几行来解决这个问题。 然后计算最终无法find并报告的定义和分类。

  ' 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