提高翻译macros的效率：在Excel中查找和打开/closures程序
我刚刚为我的公司写了一小段代码，作为给翻译朋友的礼物。 它会从我们公司内部的词典（左边的英文，右边的日文）中生成一组与所选文本的search结果匹配的button。 我刚刚使用一个快捷键并运行它，每次我想用它的翻译replace一个新的单词。 我认为在Excel表格中的“查找”function可以改进的地方。 另外，我不确定翻译单是否全部打开或每次打开和closures都不行。 电子表格包含大约10000个字和词组，因此它是相当大的，并且将被多个人同时使用。 有没有人有关于这两点或任何其他build议，如何改善这方面的build议？
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 谢谢。
我认为翻译是一个非常有趣的概念，所以我写了自己的。
在我的版本中，分隔的数据存储在全局数组中。 第二个数组使用VBA Filter方法填充所有可能的匹配项。 接下来将选项编号加载到InputBox中。 用户将单词或短语input到ActiveCell中，运行macros，input选项编号并翻译ActiveCell。 如果ActiveCell值是英文，则翻译成日文，如果是日文，则翻译成英文。
下载翻译.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
更新：
创build一个新的Excel实例，打开translations.xlsx，将数据传输到公共数组并清理需要2.24秒。 我将数组转储到一个文本文件中，并查看加载数组需要多长时间。 VBA计时器测量一秒的分数，表示从文本文件加载数组需要0秒。
下载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