I have a fully functional macro that goes through a list of personnel records and works out if they are leavers or never started. The only issue is its a very slow process when search the string created with all the HTML code (~10000 characters)
I was wondering if there is a way to restrict the retrieve to be just part of the webpage
The macro i am currently using is below, this macro iterates through each row and pulls in the code from the URL for each persons personnel page
Sub RetrieveEndDate()
Dim myArray() As Variant, Search As Variant
Dim strURL As String, strCSV As String, dbClose As String
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Call LogOn
RowsWithData = Application.CountA(Range("A:A"))
For R = 2 To RowsWithData
Application.StatusBar = R & " Out of " & RowsWithData
UKNo = Cells(R, 1).Value
strURL = "http://www.pers.fs.com/People_Detail.asp?Pers_no=" & UKNo & "&mode=CURRENT"
Set http = CreateObject("MSXML2.XMLHTTP")
http.Open "GET", strURL, False
http.Send
strCSV = http.responseText
Cells(R, 3).Value = strCSV
'Works of if employee has left, never started or if neither of them leaves blank
If InStr(1, strCSV, "Employee has Left") > 0 Then
Cells(R, 2).Value = "Left"
ElseIf InStr(1, strCSV, "Non-Starter") > 0 Then
Cells(R, 2).Value = "Did not start"
Else
Cells(R, 2).Value = ""
End If
Set http = Nothing
Next R
1
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
The retrieve from the webpage is ~10000 characters long, but the info i am interested in is at the beginning of the page as below "(Employee has Left)"which is on the 3rd from bottom line
<head>
<title> List</title>
<link rel="stylesheet" href="_stylesheets/atc.css" type="text/css">
</head>
<body CLASS="Skill" >
<form name="People_Detail" method="Post" action=History_list.asp>
<P><INPUT id="Pers_No" type = "HIDDEN" name="Pers_No" value=UK111111 ></P>
<P><INPUT id="mode" type = "HIDDEN" name="mode"Value="HISTORY_LIST"></P>
<Table Border = 0 CellPadding = 0 width = 100% >
<TR><TR><TD Colspan = 2 ><H1 id=Test name=test>Current Active Record<BR>(Employee has Left)</H1><TD align = right>
<P><INPUT id="btnSubmit" name="btnSubmit" type="SUBMIT" value="View Record History List"></P>
</TD></TD></TR></TR>
AFAIK there is no way do this with XMLHTTP.
This KB article contains code that performs a download using the WinInet API.
The While bDoLoop loop reads the URL in Len(sReadBuffer) chunks, you can modify this to add a condition and exit the loop whenever you like.
If you wanted to begin the download at a specific offset (and the server supports it) you could also try InternetSetFilePointer.
I had a similar problem. The reponse text at a certain website was sooo big that it was taking my macro forever to search through it. A solution that I came up with is as follows. First I used the SPLIT function on the response text.
arr_1 = Split(my_var, "zc-st-a", -1, vbTextCompare)
You didn't provide enough of the source code for me to be specific, but there is usually some tag you can split on that breaks the response text down into array elements with data you want and those elements without useful information. Next use the FILTER function to filter out the useless elements in arr_1
arr_2 = Filter(arr_1, "zc-pg-y", True, vbTextCompare)
Finally, you can combine the useful elements that are present in arr_2 using the JOIN function.
my_var = Join(arr_2, " ")
In my case, using this method to make the response text smaller reduced my macro run time from 1 hour 15 minutes to 15 minutes. Hope this helps
Related
Good afternoon guys. In a follow up to a previous query which was very much solved by QHarr, I was wanting to run the solved query against multiple fields from the source code rather than just one.
The URL I am using is: https://finance.yahoo.com/quote/AAPL/?p=AAPL
and the VBA code which takes the 'Previous Close' price is:
Option Explicit
Sub PreviousClose()
Dim html As HTMLDocument, http As Object, ticker As Range
Set html = New HTMLDocument
Set http = CreateObject("WINHTTP.WinHTTPRequest.5.1")
Dim lastRow As Long, myrng As Range
With ThisWorkbook.Worksheets("Tickers")
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set myrng = .Range("A2:A" & lastRow)
For Each ticker In myrng
If Not IsEmpty(ticker) Then
With http
.Open "GET", "https://finance.yahoo.com/quote/" & ticker.Value & "?p=" & ticker.Value, False
.send
html.body.innerHTML = .responseText
End With
On Error Resume Next
ticker.Offset(, 1) = html.querySelector("[data-test=PREV_CLOSE-value]").innertext
On Error GoTo 0
End If
Next
End With
End Sub
Anyway, each field would ideally be in a row right of the ticker used for the stock.
Screenshot of Sheet:
Any help would be very much appreciated.
Thanks.
tl;dr;
The code below works for the given test cases. With much longer lists please see the ToDo section.
API:
You want to look into an API to provide this info if possible. I believe Alpha Vantage now provide info the Yahoo Finance API used to* . There is a nice JS tutorial here. Alpha Vantage documentation here. At the very bottom of this answer, I have a quick look at the time series functions available via the API.
WEBSERVICE function:
With an API key, you can also potentially use the webservice function in Excel to retrieve and parse data. Example here. Not tested.
XMLHTTPRequest and class:
However, I will show you a way using a class and a loop over URLs. You can improve on this. I use a bare bones class called clsHTTP to hold the XMLHTTP request object. I give it 2 methods. One, GetHTMLDoc, to return the request response in an html document, and the other, GetInfo, to return an array of the items of interest from the page.
Using a class in this way means we save on the overhead of repeatedly creating and destroying the xmlhttp object and provides a nice descriptive set of exposed methods to handle the required tasks.
It is assumed your data is as shown, with header row being row 2.
ToDo:
The immediately obvious development, IMO, is you will want to add some error handling in. For example, you might want to develop the class to handle server errors.
VBA:
So, in your project you add a class module called clsHTTP and put the following:
clsHTTP
Option Explicit
Private http As Object
Private Sub Class_Initialize()
Set http = CreateObject("MSXML2.XMLHTTP")
End Sub
Public Function GetHTMLDoc(ByVal URL As String) As HTMLDocument
Dim html As HTMLDocument
Set html = New HTMLDocument
With http
.Open "GET", URL, False
.send
html.body.innerHTML = StrConv(.responseBody, vbUnicode)
Set GetHTMLDoc = html
End With
End Function
Public Function GetInfo(ByVal html As HTMLDocument, ByVal endPoint As Long) As Variant
Dim nodeList As Object, i As Long, result(), counter As Long
Set nodeList = html.querySelectorAll("tbody td")
ReDim result(0 To endPoint - 1)
For i = 1 To 2 * endPoint Step 2
result(counter) = nodeList.item(i).innerText
counter = counter + 1
Next
GetInfo = result
End Function
In a standard module (module 1)
Option Explicit
Public Sub GetYahooInfo()
Dim tickers(), ticker As Long, lastRow As Long, headers()
Dim wsSource As Worksheet, http As clsHTTP, html As HTMLDocument
Application.ScreenUpdating = False
Set wsSource = ThisWorkbook.Worksheets("Sheet1") '<== Change as appropriate to sheet containing the tickers
Set http = New clsHTTP
headers = Array("Ticker", "Previous Close", "Open", "Bid", "Ask", "Day's Range", "52 Week Range", "Volume", "Avg. Volume", "Market Cap", "Beta", "PE Ratio (TTM)", "EPS (TTM)", _
"Earnings Date", "Forward Dividend & Yield", "Ex-Dividend Date", "1y Target Est")
With wsSource
lastRow = GetLastRow(wsSource, 1)
Select Case lastRow
Case Is < 3
Exit Sub
Case 3
ReDim tickers(1, 1): tickers(1, 1) = .Range("A3").Value
Case Is > 3
tickers = .Range("A3:A" & lastRow).Value
End Select
ReDim results(0 To UBound(tickers, 1) - 1)
Dim i As Long, endPoint As Long
endPoint = UBound(headers)
For ticker = LBound(tickers, 1) To UBound(tickers, 1)
If Not IsEmpty(tickers(ticker, 1)) Then
Set html = http.GetHTMLDoc("https://finance.yahoo.com/quote/" & tickers(ticker, 1) & "/?p=" & tickers(ticker, 1))
results(ticker - 1) = http.GetInfo(html, endPoint)
Set html = Nothing
Else
results(ticker) = vbNullString
End If
Next
.Cells(2, 1).Resize(1, UBound(headers) + 1) = headers
For i = LBound(results) To UBound(results)
.Cells(3 + i, 2).Resize(1, endPoint-1) = results(i)
Next
End With
Application.ScreenUpdating = True
End Sub
Public Function GetLastRow(ByVal ws As Worksheet, Optional ByVal columnNumber As Long = 1) As Long
With ws
GetLastRow = .Cells(.Rows.Count, columnNumber).End(xlUp).Row
End With
End Function
Results:
Notes on GetInfo method and CSS selectors:
The class method of GetInfo extracts the info from each webpage using a css combination selector to target the page styling.
The info we are after on each page is house in two adjacent tables, for example:
Rather than mess around with multiple tables I simply target all the table cells, within table body elements, with a selector combination of tbody td.
The CSS selector combination is applied via the querySelectorAll method of HTMLDocument, returning a static nodeList.
The returned nodeList items have headers at even indices and the required data at odd indices. I only want the first two tables of info so I terminate the loop over the returned nodeList when I gave gone twice the length of the headers of interest. I use a step 2 loop from index 1 to retrieve only the data of interest, minus the headers.
A sample of what the returned nodeList looks like:
References (VBE > Tools > References):
Microsoft HTML Object Library
Alpha Vantage API:
A quick look at the time series API call shows that a string can be used
https://www.alphavantage.co/query?function=TIME_SERIES_DAILY&symbol=AA&outputsize=full&apikey=yourAPIKey
This yields a JSON response that in the Time Series (Daily) sub dictionary of the overall returned dictionary, has 199 dates returned. Each date has the following info:
A little digging through the documentation will unveil whether bundling of tickers is possible, I couldn't see this quickly, and whether more of your initial items of interest are available via a different query string.
There is more info, for example, using the TIME_SERIES_DAILY_ADJUSTED function in the URL call
https://www.alphavantage.co/query?function=TIME_SERIES_DAILY_ADJUSTED&symbol=AA&outputsize=full&apikey=yourAPIkey
Here, you then get the following:
You can parse the JSON response using a JSON parser such as JSONConverter.bas and there are also options for csv download.
* Worth doing some research on which APIs provide the most coverage of your items. Alpha Vantage doesn't appear to cover as many as my code above retrieves.
That's some slick code!! I like it a lot!! As an aside, you may want to consider using R to do this kind of thing. Look at what you can do with just a few simple lines of code!
library(finreportr)
# print available functions in finreportr
ls('package:finreportr')
my.ticker <- 'SBUX'
# set final year
my.year <- 2017
# get income for FB
my.income <- GetIncome(my.ticker, my.year)
# print result
print(head(my.income))
# get unique fields
unique.fields <- unique(my.income$Metric)
# cut size of string
unique.fields <- substr(unique.fields,1, 60)
# print result
print(unique.fields)
# set col and date
my.col <- 'Earnings Per Share, Basic'
# print earnings per share
print(my.income[my.income$Metric == my.col, ])
library(tidyquant)
# set stock and dates
my.ticker <- 'AAPL'
first.date <- '2017-01-01'
last.date <- Sys.Date()
# get data with tq_get
my.df <- tq_get(my.ticker,
get = "stock.prices",
from = first.date,
to = last.date)
print(tail(my.df))
# get key financial rations of AAPL
df.key.ratios <- tq_get("AAPL",get = "key.ratios")
# print it
print(df.key.ratios)
First, I am very new with VBA and have only got as far as I am with solutions from other questions asked online. What I have is a macro that opens IE to a specified URL, enters text into a search, loads the results, then loops the search through more specific search values.
What I am trying to do is scrape the results of a search into excel. However, the results don't appear in the resulting HTML code but look to be generated by a script on the website.
An example of the page I am searching:
https://www.gamestop.com/PickUpAtStore/75083/0/917850
When loaded the results are found on the page, but not in the page source. Looking at the page source there looks to be a script that pulls the results in:
<script id="stores" type="text/x-handlebars-template">
{{#if this}}
<ul>
{{#each this}}
<li id="{{StoreNumber}}|{{#if true}}917850 {{/if}}" class="{{#if false}}checkOnly{{/if}}"">
<div class="fluidWrapper ats-storelist" id="{{StoreNumber}}">
<div class="contactInfo">
<div class="title ats-storetitle">{{DisplayName}}</div>
<div class="address ats-storeaddress">
{{{AddressStreet}}}<br />{{AddressCityStateZip}}
</div>
<div class="phoneNumber ats-storephone">
{{Phone}}
</div>
</div>
<div class="rightInfo">
<div class="distance ats-storedistance">{{Distance}} {{#if true}}<i id="showHoldOptions_{{StoreNumber}}" class="{{#if false}} plus_{{/if}}icon"></i>{{/if}}</div>
</div>
</div>
..................
Ideally, what I would like to happen is when the results are loaded the store name, address and phone # are put into excel starting at A4, B4, C4 and adding each store to the next line.
Am I looking in the entirely wrong place to grab these results? I appreciate any help solving this.
edit adding current macro:
Sub Search_Cell()
Dim ie As Object
Dim lRow As Long
Dim URL As Range
Set ie = CreateObject("InternetExplorer.Application")
ie.Visible = True
For Each URL In Range("B1")
ie.navigate URL.Value
Application.StatusBar = "Submitting"
While ie.Busy
DoEvents
Wend
Next
For lRow = 1 To 89
With ie.document
.all("puas_search").Value = Sheets("Zipcodes").Range("A" & lRow).Value
.getElementById("puas_search").Focus
End With
Application.SendKeys ("~")
Application.Wait Now + #12:00:02 AM# 'wait 2 seconds
' Get results of search
' Add Store name to A4, Address to B4, Phone# to C4 (but for following searches start at the next empty row)
' Add following results to next row
Next lRow 'loop to next search
ie.Quit
Set ie = Nothing
MsgBox "Done"
End Sub
I solved this, I was entirely wrong thinking that the results couldn't be scraped from the html. Thank You #Tigregalis for nudging me in the right direction.
Here is the snippet of code that pulls the data I need, places it in the correct location in excel, then moves the to next row.
Set HTMLDoc = IE.document
Set Stores = HTMLDoc.getElementsByClassName("contactInfo")
For Each Store In Stores
ColNum = 1
For Each Name In Store.Children
Cells(RowNum, ColNum) = Name.innerText
ColNum = ColNum + 1
Next Name
RowNum = RowNum + 1
Next Store
I'm trying to extract a specific link from a website and I'm having trouble pulling into a String.
I have to search about 5000 companies from a website and all of the links vary. A link to the source code of an example company (Nokia) is this: view-source:http://finder.fi/yrityshaku/Nokia+oyj this is the part I'm looking at:
<div class="itemName">
<!-- Yritysnimi -->
<!-- Aukeaa aina yhteystiedot-vÃ?lilehdelle -->
<a href="/Tietoliikennepalveluja%2C+tietoliikennelaitteita/Nokia+Oyj/TAMPERE/yhteystiedot/159838" class="resultGray">
I want to extract the Substring between
<!-- Yritysnimi -->
<!-- Aukeaa aina yhteystiedot-vÃ?lilehdelle -->
<a href="
and
" class="resultGray">
this substring will vary with each company I search and so I will only know what the strings are around the substring I'm trying to extract.
I've tried to use browserIE.Document.body.innerHTML
Sub Macro1()
Set browserIE = CreateObject("InternetExplorer.Application")
browserIE.Top = 0
browserIE.Left = 800
browserIE.Width = 800
browserIE.Height = 1200
browserIE.Visible = True
Set ws = ThisWorkbook.Worksheets("Sheet1")
browserIE.Navigate ("http://www.finder.fi/yrityshaku")
Do
DoEvents
Loop Until browserIE.ReadyState = 4
browserIE.Document.getElementById("companysearchform_query_companySearchTypename").Click
browserIE.Document.getElementById("SearchInput").Value = "nokia oyj"
browserIE.Document.getElementById("SearchSubmit").Click
Application.Wait (Now + TimeValue("0:00:4"))
codeArea = Mid(V, InStr(V, "<div class=""itemName""> <!-- Yritysnimi --> <!-- Aukeaa aina yhteystiedot-vÃ?lilehdelle --> <a href="""), Len(V))
Debug.Print codeArea
theLink = Mid(codeArea, 117, InStr(codeArea, """ class=""resultGray"">" - 1))
End Sub
but I get an invalid procedure call or argument
I've researched some but I haven't found a suitable solution yet. Some have suggested pulling just an element from the source code and others copying the whole source code into a string variable. As a person who's not too expert in vba I'd prefer pulling the whole code into a string as I think this way would be easier to understand.
Original website (in finnish) http://finder.fi/yrityshaku/nokia+oyj
You need to locate all of the <div> elements with a classname of itemName. Loop through those to find the <a> element(s) and use the first one to get the href property.
Sub Macro1()
Dim browserIE As Object, ws As Worksheet
Set browserIE = CreateObject("InternetExplorer.Application")
browserIE.Top = 0
browserIE.Left = 800
browserIE.Width = 800
browserIE.Height = 1200
browserIE.Visible = True
Set ws = ThisWorkbook.Worksheets("Sheet1")
browserIE.Navigate ("http://www.finder.fi/yrityshaku")
Do While browserIE.ReadyState <> 4 And browserIE.Busy: DoEvents: Loop
browserIE.Document.getElementById("companysearchform_query_companySearchTypename").Click
browserIE.Document.getElementById("SearchInput").Value = "nokia oyj"
browserIE.Document.getElementById("SearchSubmit").Click
Do While browserIE.ReadyState <> 4 And browserIE.Busy: DoEvents: Loop
'Application.Wait (Now + TimeValue("0:00:4"))
Dim iDIV As Long
With browserIE.Document.body
If CBool(.getelementsbyclassname("itemName").Length) Then
'there is at least one div with the itemName class
For iDIV = 0 To .getelementsbyclassname("itemName").Length - 1
With .getelementsbyclassname("itemName")(iDIV)
If CBool(.getelementsbytagname("a").Length) Then
'there is at least one anchor element inside this div
Debug.Print .getelementsbytagname("a")(0).href
End If
End With
Next iDIV
End If
End With
End Sub
I added Microsoft HTML Object library and Microsoft Internet controls to the project via the VBE's Tools ► References.
Results from the Immediate window.
http://www.finder.fi/Televiestint%C3%A4laitteita+ja+palveluja/Nokia+Oyj/ESPOO/yhteystiedot/159843
http://www.finder.fi/Tietoliikennepalveluja%2C+tietoliikennelaitteita/Nokia/SALO/yhteystiedot/960395
http://www.finder.fi/Tietoliikennepalveluja%2C+tietoliikennelaitteita/Nokia/TAMPERE/yhteystiedot/853264
http://www.finder.fi/Tietoliikennepalveluja%2C+tietoliikennelaitteita/Nokia/ESPOO/yhteystiedot/2931747
http://www.finder.fi/Tietoliikennepalveluja%2C+tietoliikennelaitteita/Nokia/ESPOO/yhteystiedot/2931748
http://www.finder.fi/Tietoliikennepalveluja%2C+tietoliikennelaitteita/Nokia/TAMPERE/yhteystiedot/835172
http://www.finder.fi/Tietoliikennepalveluja%2C+tietoliikennelaitteita/Nokia+Oyj/TAMPERE/yhteystiedot/159838
http://www.finder.fi/Tietoliikennepalveluja%2C+tietoliikennelaitteita/Nokia+Oyj/SALO/yhteystiedot/159839
http://www.finder.fi/Tietoliikennepalveluja%2C+tietoliikennelaitteita/Nokia+Oyj/TAMPERE/yhteystiedot/159850
http://www.finder.fi/Tietoliikennepalveluja%2C+tietoliikennelaitteita/Nokia+Oyj/TAMPERE/yhteystiedot/159857
I am relatively new to VBA and am trying to put together a msgbox that will give me a specific number from a web scrape, however I keep running into a run-time error '91' and I simply cannot figure out how to fix this. I have searched countless stackoverflow questions, youtube videos and generic google searches, however have not been successful in finding out the error on my own.
Here is the code:
Set IE = CreateObject("InternetExplorer.Application")
IE.Visible = True
IE.Navigate ("http://brokercheck.finra.org")
Do
DoEvents
Loop Until IE.ReadyState = 4
'Enter values from the corresponding sheet
'Set some generic typing for ease
Set doc = IE.document
doc.GetElementbyID("GenericSearch_IndividualSearchText").Value = Worksheets("Master").Range("D203")
doc.GetElementbyID("GenericSearch_EmploymingFirmSearchText").Value = Worksheets("Master").Range("C203")
Set elements = doc.getElementsByTagName("button")
For Each element In elements
If element.getAttribute("type") = "submit" Then
element.Click
Exit For
End If
Next element
Do
DoEvents
Loop Until IE.ReadyState = 4
'find CRD#
Set crd = doc.getElementsByClassName("summarydisplaycrd")(0).innerText 'here is where the run time error occurs
MsgBox crd
and the HTML I am trying to get the information from:
<div class="searchresulttext">
<div class="bcrow">
<div class=""> <span class="summarydisplayname">[redacted]</span> <span class="summarydisplaycrd text-nowrap">(CRD# 5944070)</span></div>
I'm reviewing this code and the finra.org site, and have the following observations, which when addressed, should resolve the problem.
The HTML example you provided is simply incorrect, based on the actual HTML that is returned from the "Check" button.
The actual HTML returned looks like this, and the classname is "displayname", not "summarydisplaycrd":
<div class="SearchResultItemColor bcrow">
<div class="searchresulttext">
<div class="bcsearchresultfirstcol">
<span class="displayname">[redacted]</span> <span class="displaycrd">(CRD# 123456789)</span>
Your code exits the For each element loop upon finding the first "submit" button. This may not be the "Check" button (although I can get results either way, you may want to add more logic in the code to ensure the "Check " button is submit.
UPDATE
On further review, while I can replicate the Type 91 error, I still don't know why your class name appears different than mine (maybe an IE11 thing, dunno...) in any case, I'm able to resolve that by forcing a longer delay, as in this case the DoEvents loop is simply not adequate (sometimes this is the case when data is served dynamically from external functions, the browser is ReadyState=4 and .Busy=True, so the loop doesn't do anything)
I use the WinAPI Sleep function and force a 1 second delay after the "Click" button pressed, looping on condition of ReadyState = 4 and .Busy=True.
NOTE you will need to modify the classname parameter depending on how it is appearing on your HTML.
Option Explicit
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub finra()
Dim IE As Object
Dim doc As Object, element As Object, elements As Object, crd
Set IE = CreateObject("InternetExplorer.Application")
IE.Visible = True
IE.Navigate ("http://brokercheck.finra.org")
Call WaitIE(IE, 1000)
'Enter values from the corresponding sheet
'Set some generic typing for ease
Set doc = IE.document
doc.GetElementbyID("GenericSearch_IndividualSearchText").Value = "steve"
doc.GetElementbyID("GenericSearch_EmploymingFirmSearchText").Value = "ed"
Set elements = doc.getElementsByTagName("button")
For Each element In elements
If element.getAttribute("type") = "submit" Then
If element.innerText = "Check " Then
element.Click
Exit For
End If
End If
Next element
Call WaitIE(IE, 1000)
Dim itms As Object
'Set itms = doc.getElementsByClassName("displaycrd")
crd = doc.getElementsByClassName("displaycrd")(0).innerText 'here is where the run time error occurs
MsgBox crd
End Sub
Sub WaitIE(IE As Object, Optional time As Long = 250)
Dim i As Long
Do
Sleep time
Debug.Print CStr(i) & vbTab & "Ready: " & CStr(IE.ReadyState = 4) & _
vbCrLf & vbTab & "Busy: " & CStr(IE.Busy)
i = i + 1
Loop Until IE.ReadyState = 4 And Not IE.Busy
End Sub
I have an Excel sheet with almost 30.000 words in column A and I want to create a macro to search each word in Google Translate, get their meaning (or translation), put the meaing in column B (or if there is more than more meaning in column C, column D, etc.)
Since I have almost 30.000 words, it is a very time consuming thing to search for each word by myself. It would be great if I can do this with a macro.
Any suggestions? (Google Translate is not a "must" for me. If there is another web-site or some other way to do this, I am open to suggestions)
Note: I came across with this topic, but it did not work out the way I hoped.
Since the Google Translate API is not the free service it's tricker to perform this operation. However, I found a workaround on this page Translate text using vba and I made some adjustments so it could work for your purposes. Assuming that the original words are entered into the "A" column in the spreadsheet and translations should appear in the colums on the right here is the code:
Sub test()
Dim s As String
Dim detailed_translation_results, basic_translation_results
Dim cell As Range
For Each cell In Intersect(ActiveSheet.Range("A:A"), ActiveSheet.UsedRange)
If cell.Value <> "" Then
detailed_translation_results = detailed_translation(cell.Value)
'Check whether detailed_translation_results is an array value. If yes, each detailed translation is entered into separate column, if not, basic translation is entered into the next column on the right
On Error Resume Next
ActiveSheet.Range(cell.Offset(0, 1), cell.Offset(0, UBound(detailed_translation_results) + 1)).Value = detailed_translation_results
If Err.Number <> 0 Then
cell.Offset(0, 1).Value = detailed_translation_results
End If
On Error GoTo 0
End If
Next cell
End Sub
Function detailed_translation(str)
' Tools Refrence Select Microsoft internet Control
Dim IE As Object, i As Long, j As Long
Dim inputstring As String, outputstring As String, text_to_convert As String, result_data As String, CLEAN_DATA
Dim FirstTablePosition As Long, FinalTablePosition
Set IE = CreateObject("InternetExplorer.application")
' Choose input language - Default "auto"
inputstring = "auto"
' Choose input language - Default "en"
outputstring = "en"
text_to_convert = str
'open website
IE.Visible = False
IE.navigate "http://translate.google.com/#" & inputstring & "/" & outputstring & "/" & text_to_convert
Do Until IE.ReadyState = 4
DoEvents
Loop
Application.Wait (Now + TimeValue("0:00:5"))
Do Until IE.ReadyState = 4
DoEvents
Loop
'Firstly, this function tries to extract detailed translation.
Dim TempTranslation() As String, FinalTranslation() As String
FirstTablePosition = InStr(IE.Document.getElementById("gt-lc").innerHTML, "<tbody>")
LastTablePosition = InStr(IE.Document.getElementById("gt-lc").innerHTML, "</tbody>")
On Error Resume Next
TempTranslation() = Split(Mid(IE.Document.getElementById("gt-lc").innerHTML, FirstTablePosition, LastTablePosition - FirstTablePosition), "class=""gt-baf-cell gt-baf-word-clickable"">")
ReDim FinalTranslation(0 To UBound(TempTranslation) - 1)
For j = LBound(TempTranslation) + 1 To UBound(TempTranslation)
FinalTranslation(j - 1) = Left(TempTranslation(j), InStr(TempTranslation(j), "<") - 1)
Next j
On Error GoTo 0
Dim CheckIfDetailed
'Check whether there is detailed translation available. If not - this function returns a single translation
On Error Resume Next
CheckIfDetailed = FinalTranslation(LBound(FinalTranslation))
If Err.Number <> 0 Then
CLEAN_DATA = Split(Application.WorksheetFunction.Substitute(IE.Document.getElementById("result_box").innerHTML, "</SPAN>", ""), "<")
For j = LBound(CLEAN_DATA) To UBound(CLEAN_DATA)
result_data = result_data & Right(CLEAN_DATA(j), Len(CLEAN_DATA(j)) - InStr(CLEAN_DATA(j), ">"))
Next
detailed_translation = result_data
Exit Function
End If
On Error GoTo 0
IE.Quit
detailed_translation = FinalTranslation()
End Function
Please note that the code is extremly slow (due to anti-robot restrictions) and I cannot guarantee that Google will not block the script. However, it should work.
The only thing you should do is to choose languages in the places marked by the appropriate comment.
Alternatively, if you seek something faster, you can manipulate Application.Wait method (for example setting the value to 0:00:2 instead of 0:00:5) or google for Microsoft Translate.