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方法填充所有可能的匹配项。接下来，编号的选项被加载到InputBox中。用户将单词或短语输入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，将数据传输到公共阵列并进行清理需要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

提高翻译宏观效率：在Excel中使用查找和打开/关闭程序

1 个答案: