run VBA when clicked

[Gylle]

Hi

I have been using this VBA with great pleasure.

now i been trying to get it stop for autorun on change and only run when call from button clicked

Option Explicit


#If VBA7 Then
    Private Declare PtrSafe Function MessageBoxW Lib "user32" (ByVal hWnd As LongPtr, ByVal lpText As LongPtr, ByVal lpCaption As LongPtr, ByVal uType As Long) As Long
#Else
    Private Declare Function MessageBoxW Lib "user32" (ByVal hWnd As Long, ByVal lpText As Long, ByVal lpCaption As Long, ByVal uType As Long) As Long
#End If


Public Sub Test()
   
    Dim inputText As String, translation As String
   
    inputText = InputBox("Enter English text to translate to Spanish")
    If inputText <> "" Then
        translation = GoogleTranslate(inputText, "en", "es")   'English to Spanish
        Range("A1").Value = inputText
        Range("A2").Value = translation
        MsgBoxW inputText & vbCrLf & translation
    End If
       
End Sub


'Google Language Codes - full list at https://cloud.google.com/translate/docs/languages/

'Auto Detect = 0 Bulgarian = bg Finnish = fi Hungarian = hu Latvian = lv Russian = ru Turkish = tr
'English = en  Catalan = ca  French = fr  Icelandic = is Lithuanian = lt Serbian = sr Ukrainian = uk
'Afrikaans = af Chinese = zh Galician = gl Indonesian = id Macedonian = mk Slovak = sk Urdu = ur
'Albanian = sq Croatian = hr Georgian = ka Irish = ga Malay = ms Slovenian = sl Vietnamese = vi
'Arabic = ar Czech = cs German = de Italian = it Maltese = mt Spanish = es Welsh = cy
'Armenian = hy Danish = da Greek = el Japanese = ja Norwegian = no Swahili = sw Yiddish = yi
'Azerbaijani = az Dutch = nl Gujarati = gu Kannada = kn Persian = fa Swedish = sv
'Basque = eu Esperanto = eo Haitian_Creole = ht Korean = ko Polish = pl Tamil = ta
'Belarusian = be Estonian = et Hebrew = iw Lao = lo Portuguese = pt Telugu = te
'Bengali = bn Filipino = tl Hindi = hi Latin = la Romanian = ro Thai = th

Public Function GoogleTranslate(text As String, Optional fromLanguage As String = "en", Optional toLanguage As String = "es") As String

    Static objHTTP As Object
    Dim URL As String
   
    If objHTTP Is Nothing Then Set objHTTP = CreateObject("MSXML2.XMLHTTP")
   
    If Val(Application.Version) >= 15 Then
        'Excel 2013 and later versions - encode the Google Translate URL using the WorksheetFunction.EncodeURL function
        URL = "https://translate.google.com/m?hl=" & LCase(fromLanguage) & "&sl=" & LCase(fromLanguage) & "&tl=" & LCase(toLanguage) & "&ie=UTF-8&prev=_m&q=" & WorksheetFunction.EncodeURL(text)
    Else
        'Excel 2010 and earlier versions - encode the Google Translate URL using our own function
        URL = "https://translate.google.com/m?hl=" & LCase(fromLanguage) & "&sl=" & LCase(fromLanguage) & "&tl=" & LCase(toLanguage) & "&ie=UTF-8&prev=_m&q=" & URLEncode(text)
    End If
   
    With objHTTP
        .Open "GET", URL, False
        .setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
        .Send ("")
        If InStr(.responseText, "<div class=""result-container""") > 0 Then
            'OLD GoogleTranslate = Clean(RegexExecute(.responseText, "div[^""]*?""result-container"".*?>(.+?)</div>"))
            GoogleTranslate = Clean(RegexExecute(.responseText, "div[^""]*?""result-container"".*?>([\s\S]+?)</div>"))
        Else
            GoogleTranslate = CVErr(xlErrValue)
        End If
    End With

End Function


Private Function Clean(Val As String) As String

    Val = Replace(Val, "&quot;", """")
    Val = Replace(Val, "%2C", ",")
    Val = Replace(Val, "&#39;", "'")
    Clean = Val

End Function


Private Function RegexExecute(str As String, reg As String, Optional matchIndex As Long, Optional subMatchIndex As Long) As String

    Static RegEx As Object
    Dim matches As Object

    On Error GoTo ErrorHandler

    If RegEx Is Nothing Then Set RegEx = CreateObject("VBScript.RegExp")
    RegEx.Pattern = reg
    RegEx.Global = Not (matchIndex = 0 And subMatchIndex = 0)
    If RegEx.Test(str) Then
        Set matches = RegEx.Execute(str)
        RegexExecute = matches(matchIndex).SubMatches(subMatchIndex)
        Exit Function
    End If
   
ErrorHandler:
    RegexExecute = CVErr(xlErrValue)

End Function


Private Function MsgBoxW(Prompt As String, Optional Buttons As VbMsgBoxStyle = vbOKOnly, Optional Title As String = "Microsoft Excel") As VbMsgBoxResult
    Prompt = Prompt & vbNullChar 'Add null terminators
    Title = Title & vbNullChar
    MsgBoxW = MessageBoxW(Application.hWnd, StrPtr(Prompt), StrPtr(Title), Buttons)
End Function


'VBA function to URL-encode a string because WorksheetFunction.EncodeURL is only available in Excel 2013 and later
'https://stackoverflow.com/a/218199
'with late binding of Microsoft ActiveX Data Objects, so no VBA project reference is required

Public Function URLEncode(ByVal StringVal As String, Optional SpaceAsPlus As Boolean = False) As String

    Dim bytes() As Byte, b As Byte, i As Integer, space As String
   
    Const adTypeBinary = 1
    Const adTypeText = 2
    Const adModeReadWrite = 3

    If SpaceAsPlus Then space = "+" Else space = "%20"
   
    If Len(StringVal) > 0 Then
        With CreateObject("ADODB.Stream") 'New ADODB.Stream
            .Mode = adModeReadWrite
            .Type = adTypeText
            .Charset = "UTF-8"
            .Open
            .WriteText StringVal
            .Position = 0
            .Type = adTypeBinary
            .Position = 3 ' skip BOM
            bytes = .Read
        End With
       
        ReDim result(UBound(bytes)) As String
       
        For i = UBound(bytes) To 0 Step -1
            b = bytes(i)
            Select Case b
                Case 97 To 122, 65 To 90, 48 To 57, 45, 46, 95, 126
                    result(i) = Chr(b)
                Case 32
                    result(i) = space
                Case 0 To 15
                    result(i) = "%0" & Hex(b)
                Case Else
                    result(i) = "%" & Hex(b)
            End Select
        Next i
       
        URLEncode = Join(result, "")
    End If
   
End Function


Public Sub RegisterGoogleTranslateFunction()

    Dim strFunc As String 'name of the function you want to register
    Dim strDesc As String 'description of the function itself
    Dim strArgs() As String 'description of function arguments
   
    ReDim strArgs(1 To 3) 'The upper bound is the number of arguments in your function
    strFunc = "GoogleTranslate"
    strDesc = "Translates a text string from the specified language (default English) to another language. Language codes are listed at https://cloud.google.com/translate/docs/languages/"
    strArgs(1) = "Text string to translate."
    strArgs(2) = "Translate FROM language code.  Default ""en"" (English); use ""0"" to automatically detect the language."
    strArgs(3) = "Translate TO language code.  Default ""es"" (Spanish)."
   
    'Application.MacroOptions arguments: [Macro], [Description], [HasMenu], [MenuText], [HasShortcutKey], [ShortcutKey], [Category], [StatusBar], [HelpContextID], [HelpFile], [ArgumentDescriptions]
    'https://stackoverflow.com/questions/27962808/excel-user-defined-functions-cant-use-argumentdescriptions-in-excel-2007-im-t
   
    #If VBA7 Then
        'Excel 2010 and later - ArgumentDescriptions argument is supported
        Application.MacroOptions Macro:=strFunc, Description:=strDesc, Category:="User Defined", ArgumentDescriptions:=strArgs
    #Else
        'Excel 2007 and earlier - ArgumentDescriptions argument is not supported
        Application.MacroOptions Macro:=strFunc, Description:=strDesc, Category:="User Defined"
    #End If
       
End Sub


Public Sub DeregisterGoogleTranslateFunction()

    Dim strFunc As String 'name of the function you want to deregister
   
    strFunc = "GoogleTranslate"
    Application.MacroOptions Macro:=strFunc, Description:=Empty, Category:=Empty
   
End Sub

 

[6StringJazzer]

There is nothing in this code that will cause it to run on change. Do you have code in a worksheet module or ThisWorkbook for Sub Worksheet_Change? If so, please show that entire sub.

Do you already have a button that will run this code? If not, what type of button do you want to use?

 

[AlphaFrog]

You probably have more code located in a Worksheet or the ThisWorkbook code module.

It is the code the auto-triggers when you make a change to a cell and probably calls your Test macro. It may look something like...

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
 Call Test
End Sub

You can comment out all that code.
Then add a button to your worksheet and assign your Test macro to it or whatever macro you like. It's not clear exactly what you are trying to do.

 

[Gylle]

the VBA code is located in module1

the code is called from the worksheet with this fomular:

=IF(C5<>"";GoogleTranslate(C5;"da";"en");"")

but ... the fomular run from C5 to C79

so basicly it is the "googleTranslate" i want to call with button click

 

[Gylle]

OMG

i'm so stupid

it was not the vba that i needed to change it was the formular.

i now call the VBA with a button with this VBA

Sub Button_Click()
    Dim inputText As String
    Dim translatedText As String
    Dim cell As Range
    
    ' Loop through each cell in the range C5:C79
    For Each cell In Range("C5:C79")
        inputText = cell.Value
        
        ' Call the RunVBA function to translate if the cell is not empty
        If inputText <> "" Then
            translatedText = GoogleTranslate(inputText, "da", "en")
            ' Output the translated text to the corresponding cell in column D
            cell.Offset(0, 1).Value = translatedText ' This refers to the cell in column D
        Else
            cell.Offset(0, 1).Value = "" ' Clear the corresponding cell in column D if C is empty
        End If
    Next cell
End Sub