Excel首字母縮略詞自動查找，定義和分類添加

Question

我一直在使用在這里找到的代碼，但是我很難讓它為我完成另一項任務。 我在我的excel文檔中添加了另一列（3），其中包含首字母縮寫詞和定義的“分類”，我想將其添加到首字母縮寫詞之前的第1列中新創建的單詞doc中。 我嘗試了幾種不同的方法來移動提供的代碼，但這總是會導致錯誤。 任何幫助表示贊賞。 我已經在下面包含了工作代碼。 就像我說的那樣，它確實有效，我只希望它再做一件事。 謝謝！

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

Answer 1

如果有人在尋找這種解決方案，我可以通過重復以下幾行來弄清楚。 然后計算無法找到多少個定義和分類，最后報告。

               ' 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