Verbesserung der Effizienz von Translation Macro: Verwenden von Suchen in Excel und Öffnen/Schließen des Programms

Question

Ich habe gerade ein kleines Stück Code für meine Firma als eine Art Geschenk für meine Übersetzer Freunde abgeschlossen. Es erzeugt eine Reihe von Schaltflächen aus unserem internen Firmenwörterbuch (Englisch auf der linken Seite, Japanisch auf der rechten Seite), die mit den Suchergebnissen für den ausgewählten Text übereinstimmen. Ich habe gerade einen Tastenkürzel benutzt und jedesmal ausgeführt, wenn ich ein neues Wort durch seine Übersetzung ersetzen möchte. Ich denke, wo es verbessert werden kann, ist in der "Suche" -Funktion in der Excel-Tabelle. Ich bin mir auch nicht sicher, ob es besser ist, zu versuchen, das Übersetzungsblatt die ganze Zeit offen zu lassen oder es jedes Mal öffnen und schließen zu lassen, wenn es benutzt wird. Die Tabelle enthält etwa 10000 Wörter und Sätze, ist also ziemlich groß und wird von mehreren Personen gleichzeitig verwendet. Hat jemand Vorschläge zu diesen zwei Punkten oder andere Vorschläge, wie man das verbessert?

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 

Vielen Dank.

Answer 1

Ich dachte, dass der Übersetzer ein ziemlich interessantes Konzept war, also schrieb ich mein eigenes.

In meiner Version werden die begrenzten Daten in einem globalen Array gespeichert. Ein zweites Array wird mit allen möglichen Übereinstimmungen mithilfe der VBA-Filtermethode gefüllt. Als nächstes werden die nummerierten Optionen in eine InputBox geladen. Der Benutzer gibt das Wort oder die Phrase in die ActiveCell ein, führt das Makro aus, gibt die Optionsnummer ein und die ActiveCell wird übersetzt. Wenn der ActiveCell-Wert Englisch ist, wird es ins Japanische übersetzt und wenn es Japanisch ist, wird es ins Englische übersetzt.

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 

---

Update:

eine neue Instanz von Excel Erstellen, Öffnen der translations.xlsx, die Daten in einem öffentlichen Array übertragen und Reinigung es dauerte 2,24 Sekunden. Ich dump das Array in eine Textdatei und sehen, wie lange es dauern würde, das Array zu laden. Der VBA-Timer, der Bruchteile von Sekunden misst, sagte, dass es 0 Sekunden dauerte, das Array aus einer Textdatei zu laden.

Download translations.txt

Hier ist der Code ein translations.txt als Datenquelle verwendet wird. Es ist so schnell, dass ich nicht einmal ein globales Array verwende. Ich lade es einfach jedes Mal neu.

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 

---

ich das Array in eine Textdatei verwenden diesen Code abgeladen:

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