CODEWITHSUNDEEP
vbaexcelms-word
Zack
Zack

Reputation: 33

Using Find in Excel and Opening/Closing the Program

I wrote translation code. It generates buttons from our internal company dictionary (English on the left, Japanese on the right) that match search results for the selected text. I am using a shortcut key and running it each time I want to replace a new word with its translation.

I think where it can be improved is in the "Find" function in the Excel sheet.

Also, is it better to leave the translation sheet open the whole time or have it open and close each time it's used?

The spreadsheet contains about 10000 words and phrases, so it is pretty large, and will be used by multiple people at once.

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

Upvotes: 2

Views: 435

Answers (1)

user6432984
user6432984

Reputation:

I thought that the translator was a pretty interesting concept, so I wrote my own.

In my version the delimited data is stored in a global array. A second array is filled with all possible matches using the VBA Filter method. Next the options are numbered are loaded into an InputBox. The user enters the word or phrase into the ActiveCell, runs the macro, inputs the option number and the ActiveCell is translated. If the ActiveCell value is English it is translated to Japanese and if it is Japanese it is translated into English.

enter image description here

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:

Creating a new instance of Excel, opening the translations.xlsx, transferring the data into a public array and cleaning up was taking 2.24 seconds. I dump the array into a text file and see how long it would take to load the array. The VBA Timer which measures fractions of a second said that it took 0 seconds to load the array from a text file.

Download translations.txt

Here is the code using a translations.txt as the datasource. It is so fast I don't even use a global array. I just reload it every time.

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

I dumped the array into a text file use this code:

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

Upvotes: 2

Related Questions