vba - 使用 Excel 中的查找并打开/关闭程序

Question

我写了翻译代码。它从我们的内部公司词典(左侧为英语，右侧为日语)生成与所选文本的搜索结果相匹配的按钮。我使用快捷键并在每次想要用其翻译替换新单词时运行它。

我认为可以改进的地方是Excel工作表中的“查找”功能。

此外，是让翻译表始终打开还是每次使用时都打开并关闭更好？

该电子表格包含大约 10000 个单词和短语，因此相当大，并且会被多人同时使用。

Sub TranslationsOnRightClick()
    ''''Displays Translations From Right Click for a Selection in the Menu Bar.
    ' Recommended to map to a quick-key'''''''''''''''''''''''''
    Dim oBtn As CommandBarButton
    Dim oCtr As CommandBarControl
    Dim Current As String
    Dim oSheet As Excel.Range
    Dim firstAddress As String
    Dim oExcel As Excel.Application
    Dim sFname As String
    Dim oChanges As Excel.Workbook
    Dim c As Excel.Range
    Dim FoundTextEng As String
    Dim FoundTextJap As String

    On Error GoTo ErrorHandler
    Set oExcel = New Excel.Application
    oExcel.Visible = False
    ''''Insert Source Table Location Below''''''''''''''''''''''''''''''''''''''''''
    sFname = "C:\Users\User\Desktop\translations.xlsx"
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Set oChanges = oExcel.Workbooks.Open(FileName:=sFname)
    Set oSheet = oChanges.ActiveSheet.UsedRange
     'Prepping Excel File
    For Each oCtr In Application.CommandBars("Text").Controls
        If Not oCtr.BuiltIn Then
            oCtr.Delete
        End If
    Next oCtr
    'Clear buttons from previous selection
    Current = Selection
    With oSheet
        Set c = .Find(Current)
        If Not c Is Nothing Then
            firstAddress = c.Address
            Do
                Set oBtn = Application.CommandBars("Text").Controls.Add(msoControlButton, , , 1)
                FoundTextEng = oChanges.ActiveSheet.Cells(c.Row, 1).Value
                FoundTextJap = oChanges.ActiveSheet.Cells(c.Row, 2).Value
                With oBtn
                    .Caption = FoundTextEng + " | " + FoundTextJap
                    .Style = msoButtonCaption
                    .Tag = FoundTextJap
                    .OnAction = "NewMacros.TranslationButton"
                End With
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> firstAddress
        End If
        
    End With

ErrorHandler:
    oChanges.Close SaveChanges:=wdDoNotSaveChanges
    oExcel.Quit
    Exit Sub

lbl_Exit:
    oChanges.Close SaveChanges:=wdDoNotSaveChanges
    oExcel.Quit
    Exit Sub
    oChanges.Close SaveChanges:=wdDoNotSaveChanges
    oExcel.Quit
End Sub

Sub TranslationButton()
    ''''Inserts Selected Text From Clicking Button Not to be Run Alone''''
    Dim cbCtrl As CommandBarControl
    Set cbCtrl = CommandBars.ActionControl
    Options.ReplaceSelection = True
    Selection.TypeText (cbCtrl.Tag)
End Sub

Answer 1

我认为翻译器是一个非常有趣的概念，所以我编写了自己的概念。

在我的版本中，分隔数据存储在全局数组中。第二个数组使用 VBA Filter 方法填充所有可能的匹配项。接下来，将编号的选项加载到输入框中。用户在 ActiveCell 中输入单词或短语，运行宏，输入选项编号，然后 ActiveCell 被翻译。如果 ActiveCell 值是英语，则将其翻译为日语；如果是日语，则将其翻译为英语。

Download translations.xlsx

'Source Data: http://www.langage.com/vocabulaire/learn_japanese.htm

Public JapaneseTranslationArray() As String
Public Const Delimeter As String = " | "
Public Const APPNAME As String = "Japanese Translator"

Sub ShowTranslations()
    Dim StartTime
    Dim MacthString As String, msg As String
    Dim isInitialized As Boolean
    Dim x As Long
    Dim arrData, result, index

    On Error Resume Next
    isInitialized = UBound(JapaneseTranslationArray) > -1
    On Error GoTo 0

    If Not isInitialized Then InitiateJapaneseTranslationArray

    MacthString = Trim(ActiveCell.Value)
    arrData = Filter(JapaneseTranslationArray, MacthString, True, vbTextCompare)

    If UBound(arrData) = -1 Then
        MsgBox "No Matches Found", vbInformation, APPNAME
    Else
        For x = 0 To UBound(arrData)
            msg = msg & vbNewLine & (x + 1) & ". " & arrData(x)
        Next
    End If

    index = InputBox(msg, APPNAME)

    If IsNumeric(index) Then
        result = arrData(index - 1)

        If InStr(result, MacthString) > InStr(result, Delimeter) Then
            ActiveCell.Value = Trim(Split(result, Delimeter)(0))
        Else
            ActiveCell.Value = Trim(Split(result, Delimeter)(1))
        End If

    End If

End Sub

Sub InitiateJapaneseTranslationArray()
   Const TRANSLATIONS_PATH As String = "C:\Users\User\Desktop\translations.xlsx"

    Dim oExcel As Excel.Application
    Dim rData As Range
    Dim FilePath As String
    Dim oChanges As Excel.Workbook
    Dim x As Long
    Dim arrData

    If Len(Dir(TRANSLATIONS_PATH)) = 0 Then
        MsgBox "Translations File Not Found", vbCritical, APPNAME
        Exit Sub
    End If

    On Error GoTo ErrorHandler
    Set oExcel = New Excel.Application
    Set oChanges = oExcel.Workbooks.Open(Filename:=TRANSLATIONS_PATH)
    With oChanges.ActiveSheet
        Set rData = oExcel.Intersect(.Columns("A:B"), .UsedRange)

        If rData Is Nothing Then
            MsgBox "No Data Found", vbCritical, APPNAME
            GoTo ErrorHandler
        Else
            If rData.Columns.Count < 2 Then
                MsgBox "No Data Found", vbCritical, APPNAME
                GoTo ErrorHandler
            Else
                arrData = rData.Value
            End If
        End If
    End With

    ReDim JapaneseTranslationArray(UBound(arrData) - 1)

    For x = 1 To UBound(arrData)
        JapaneseTranslationArray(x - 1) = arrData(x, 1) & Delimeter & arrData(x, 2)
    Next

    isInitialized = True

ErrorHandler:
    oChanges.Close SaveChanges:=False
    oExcel.Quit

End Sub

---

更新:

创建新的 Excel 实例、打开 Translations.xlsx、将数据传输到公共(public)数组并进行清理耗时 2.24 秒。我将数组转储到文本文件中，然后查看加载该数组需要多长时间。测量几分之一秒的 VBA 计时器表示从文本文件加载数组花了 0 秒。

Download translations.txt

这是使用 Translations.txt 作为数据源的代码。它是如此之快，我什至不使用全局数组。我每次都重新加载它。

Sub ShowTranslations2()
    Const Delimeter As String = " | "
    Const APPNAME As String = "Japanese Translator"
    Const TRANSLATIONS_PATH As String = "C:\Users\best buy\Downloads\stackoverfow\translations.txt"
    Dim MacthString As String, msg As String
    Dim x As Long
    Dim arrDictionary() As String
    Dim arrData, result, index

    On Error GoTo ErrHandler

    If Len(Dir(TRANSLATIONS_PATH)) = 0 Then
        MsgBox "Translations File Not Found", vbCritical, APPNAME
        Exit Sub
    End If

    Open TRANSLATIONS_PATH For Input As #1

    Do Until EOF(1)
        ReDim Preserve arrDictionary(x)
        Line Input #1, arrDictionary(x)
        x = x + 1
    Loop
    Close #1

    MacthString = Trim(ActiveCell.Value)
    arrData = Filter(arrDictionary, MacthString, True, vbTextCompare)

    If UBound(arrData) = -1 Then
        MsgBox "No Matches Found", vbInformation, APPNAME
    Else
        For x = 0 To UBound(arrData)
            msg = msg & vbNewLine & (x + 1) & ". " & arrData(x)
        Next
    End If

    index = InputBox(msg, APPNAME)

    If IsNumeric(index) Then
        result = arrData(index - 1)

        If InStr(result, MacthString) > InStr(result, Delimeter) Then
            ActiveCell.Value = Trim(Split(result, Delimeter)(0))
        Else
            ActiveCell.Value = Trim(Split(result, Delimeter)(1))
        End If

    End If
    Exit Sub
ErrHandler:

    MsgBox "Oops Something Went Wrong", vbInformation, APPNAME
End Sub

---

我使用以下代码将数组转储到文本文件中:

Sub PrintArray()

    Const TRANSLATIONS_PATH As String = "C:\Users\best buy\Downloads\stackoverfow\translations.txt"

    Open TRANSLATIONS_PATH For Output As #1

    Write #1, Join(JapaneseTranslationArray, vbCrLf)

    Close #1

End Sub