I have (in Excel, VBA) a sub that will navigate to this webpage:
http://www.nordea.dk/wemapp/currency/dk/valutaKurser
And copy the quoted rates. However, I would like to remove all the rates, and only add the ones my sub needs.
To do this, I need to check all of the boxes (to the left in the table), but the number of boxes is not constant - so I can't hardcode the boxnames.
I suppose one way to this is to extract the entire html, determine the number of rows, and then loop. But it seems very unhandy. Surely there is some smatter way, which requires less code and less storage?
You can Split() the table by vbNewLine and search for the currency in each row of the set (mind the headers).
Since the inputs are named like table:body:rows:2:cells:1:cell:check you can match the currency with the checkbox.
In practice it looks like (up to getting the element names):
Function FirstRow(myArray() As String, Optional curr As String) As Long
If curr = "" Then
curr = "*[A-Z][A-Z][A-Z]/[A-Z][A-Z][A-Z]*"
Else
curr = "*" & curr & "*"
End If
For i = LBound(myArray) To UBound(myArray)
If myArray(i) Like curr Then 'FX denoted as "XXX/XXX"
FirstRow = i
Exit Function
End If
Next i
End Function
Sub ert()
Dim myArray() As String, URLStr As String
URLStr = "http://www.nordea.dk/wemapp/currency/dk/valutaKurser"
Set ie = CreateObject("InternetExplorer.Application")
ie.Visible = False
ie.Navigate URLStr
Do Until (ie.readyState = 4 And Not ie.Busy)
DoEvents
Loop
On Error GoTo Err:
Data = ie.Document.body.innerHTML 'innerText
If False Then
Err:
Data = ie.Document.body.innerHTML
End If
myArray = Split(Data, "<tr>") 'vbNewLine) 'vbCrLf)
'For i = LBound(myArray) To UBound(myArray)
' Cells(i + 1, 1).Value2 = myArray(i)
'Next
Dim curr() As String
ReDim curr(2)
curr(0) = "DKK/NOK"
curr(1) = "EUR/SEK"
curr(2) = "USD/CHF"
For i = LBound(curr) To UBound(curr)
x = FirstRow(myArray, curr(i)) - FirstRow(myArray) + 1
MsgBox "table:body:rows:" & x & ":cells:1:cell:check"
Next i
ie.Quit
Set ie = Nothing
End Sub
I'm sorry, the vbNewLine won't cut it this time, my bad. Also, checking a named element shouldn't be that hard, had you provided your snipplet for checking all the boxes I would have even given it a shot.
Related
Background
Disclaimer: I am a beginner, please bare with my - most plausibly wrong - code.
I want to update currency pairs' value (PREV CLOSE) with a button-enabled-VBA macro. My Excel worksheet contains FX pairs (e.g. USDGBP) on column G:G which are then used to run a FOR loop for every pair in the column.
The value would then be stored in column I:I
Right now, the problem according to the Debugger lies in one line of code that I will highlight below
Sources
I got some inspiration from https://www.youtube.com/watch?v=JxmRjh-S2Ms&t=1050s - notably 17:34 onwards - but I want my code to work for multiple websites at the press of a button.
I have tried the following code
Public Sub Auto_FX_update_BMG()
Application.ScreenUpdating = False 'My computer is not very fast, thus I use this line of
'code to save some computing power and time
Dim internet_object As InternetExplorer
Dim i As Integer
For i = 3 To Sheets(1).Cells(3, 7).End(xlDown).Row
FX_Pair = Sheets(1).Cells(i, 7)
Set internet_object = New InternetExplorer
internet_object.Visible = True
internet_object.navigate "https://www.bloomberg.com/quote/" & FX_Pair & ":CUR"
Application.Wait Now + TimeValue("00:00:05")
internet_object.document.getElementsByClassName("class")(0).getElementsByTagName ("value__b93f12ea") '--> DEBUGGER PROBLEM
'My goal here is to "grab" the PREV CLOSE
'value from the website
With ActiveSheet
.Range(Cells(i, 9)).Value = HTML_element.Children(0).textContent
End With
Sheets(1).Range(Cells(i, 9)).Copy 'Not sure if these 2 lines are unnecesary
ActiveSheet.Paste
Next i
Application.ScreenUpdating = True
End Sub
Expected Result
WHEN I enter "USDGBP" on a cell on column G:G, the macro would go to https://www.bloomberg.com/quote/EURGBP:CUR and "grab" the PREV CLOSE value of 0.8732 (using today's value) and insert it in the respective row of column I:I
As of now, I am just facing the debugger without much idea on how to solve the problem.
You can use class selectors in a loop. The pattern
.previousclosingpriceonetradingdayago .value__b93f12ea
specifies to get child elements with class value__b93f12ea having parent with class previousclosingpriceonetradingdayago. The "." in front is a css class selector and is a faster way of selecting as modern browsers are optimized for css. The space between the two classes is a descendant combinator. querySelector returns the first match for this pattern from the webpage html document.
This matches on the page:
You can see the parent child relationship and classes again here:
<section class="dataBox previousclosingpriceonetradingdayago numeric">
<header class="title__49417cb9"><span>Prev Close</span></header>
<div class="value__b93f12ea">0.8732</div>
</section>
N.B. If you are a Bloomberg customer look into their APIs. Additionally, it is very likely you can get this same info from other dedicated APIs which will allow for much faster and more reliable xhr requests.
VBA (Internet Explorer):
Option Explicit
Public Sub test()
Dim pairs(), ws As Worksheet, i As Long, ie As Object
Set ws = ThisWorkbook.Worksheets("Sheet1")
Set ie = CreateObject("InternetExplorer.Application")
With ws
pairs = Application.Transpose(.Range("G2:G" & .Cells(.rows.Count, "G").End(xlUp).Row).Value) ' assumes pairs start in row 2
End With
Dim results()
ReDim results(1 To UBound(pairs))
With ie
.Visible = True
For i = LBound(pairs) To UBound(pairs)
.Navigate2 "https://www.bloomberg.com/quote/" & pairs(i) & ":CUR", False
While .Busy Or .readyState < 4: DoEvents: Wend
results(i) = .document.querySelector(".previousclosingpriceonetradingdayago .value__b93f12ea").innerText
Next
.Quit
End With
ws.Cells(2, "I").Resize(UBound(results), 1) = Application.Transpose(results)
End Sub
For very limited numbers of requests (as leads to blocking) you could use xhr request and regex out the value. I assume pairs are in sheet one and start from G2. I also assume there are no empty cells or invalid pairs in column G up to an including last pair to search for. Otherwise, you will need to develop the code to handle this.
Try regex here
Option Explicit
Public Sub test()
Dim re As Object, pairs(), ws As Worksheet, i As Long, s As String
Set ws = ThisWorkbook.Worksheets("Sheet1")
Set re = CreateObject("VBScript.RegExp")
With ws
pairs = Application.Transpose(.Range("G2:G" & .Cells(.rows.Count, "G").End(xlUp).Row).Value) ' assumes pairs start in row 2
End With
Dim results()
ReDim results(1 To UBound(pairs))
With CreateObject("MSXML2.XMLHTTP")
For i = LBound(pairs) To UBound(pairs)
.Open "GET", "https://www.bloomberg.com/quote/" & pairs(i) & ":CUR", False
.send
s = .responseText
results(i) = GetCloseValue(re, s, "previousClosingPriceOneTradingDayAgo%22%3A(.*?)%2")
Next
End With
ws.Cells(2, "I").Resize(UBound(results), 1) = Application.Transpose(results)
End Sub
Public Function GetCloseValue(ByVal re As Object, inputString As String, ByVal pattern As String) As String 'https://regex101.com/r/OAyq30/1
With re
.Global = True
.MultiLine = True
.IgnoreCase = False
.pattern = pattern
If .test(inputString) Then
GetCloseValue = .Execute(inputString)(0).SubMatches(0)
Else
GetCloseValue = "Not found"
End If
End With
End Function
Try below code:
But before make sure to add 2 reference by going to Tools> References > then look for Microsoft HTML Object Library and Microsoft Internet Controls
This code works upon using your example.
Sub getPrevCloseValue()
Dim ie As Object
Dim mySh As Worksheet
Set mySh = ThisWorkbook.Sheets("Sheet1")
Dim colG_Value As String
Dim prev_value As String
For a = 3 To mySh.Range("G" & Rows.Count).End(xlUp).Row
colG_Value = mySh.Range("G" & a).Value
Set ie = CreateObject("InternetExplorer.Application")
ie.Visible = True
ie.navigate "https://www.bloomberg.com/quote/" & colG_Value & ":CUR"
Do While ie.Busy: DoEvents: Loop
Do Until ie.readyState = 4: DoEvents: Loop
'Application.Wait (Now + TimeValue("00:00:03")) 'activate if having problem with delay
For Each sect In ie.document.getElementsByTagName("section")
If sect.className = "dataBox previousclosingpriceonetradingdayago numeric" Then
prev_value = sect.getElementsByTagName("div")(0).innerText
mySh.Range("I" & a).Value = prev_value
Exit For
End If
Next sect
Next a
I have a video tutorial for basic web automation using vba which include web data scraping and other commands, please check the link below:
https://www.youtube.com/watch?v=jejwXID4OH4&t=700s
i wrote my VBA code in excel sheet as below but it is not scrape data for me and also i don't know why please any one help me. it gave me reullt as "click her to read more" onlyi want to scrape enitre data such as first name last name state zip code and so on
Sub extractTablesData()
Dim IE As Object, obj As Object
Dim myState As String
Dim r As Integer, c As Integer, t As Integer
Dim elemCollection As Object
Set IE = CreateObject("InternetExplorer.Application")
myState = InputBox("Enter the city where you wish to work")
With IE
.Visible = True
.navigate ("http://www.funeralhomes.com/go/listing/Search? name=&city=&state=&country=USA&zip=&radius=")
While IE.readyState <> 4
DoEvents
Wend
For Each obj In IE.document.all.item("state").Options
If obj.innerText = myState Then
obj.Selected = True
End If
Next obj
IE.document.getElementsByValue("Search").item.Click
Do While IE.Busy: DoEvents: Loop
ThisWorkbook.Sheets("Sheet1").Range("A1:K1500").ClearContents
Set elemCollection = IE.document.getElementsByTagName("TABLE")
For t = 0 To (elemCollection.Length - 1)
For r = 0 To (elemCollection(t).Rows.Length - 1)
For c = 0 To (elemCollection(t).Rows(r).Cells.Length - 1)
ThisWorkbook.Worksheets(1).Cells(r + 1, c + 1) = elemCollection(t).Rows(r).Cells(c).innerText
Next c
Next r
Next t
End With
Set IE = Nothing
End Sub
Using the same URL as the answer already given you could alternatively select with CSS selectors to get the elements of interest, and use split to get just the names and address parts from the text. We can also do away with the browser altogether to get faster results from first results page.
Business name:
You can get the name with the following selector (using paid listing example):
div.paid-listing .listing-title
This selects (sample view)
Try
Address info:
The associated descriptive information can be retrieved with the selector:
div.paid-listing .address-summary
And then using split we can parse this into just the address information.
Code:
Option Explicit
Public Sub GetTitleAndAddress()
Dim oHtml As HTMLDocument, nodeList1 As Object, nodeList2 As Object, i As Long
Const URL As String = "http://www.funeralhomes.com/go/listing/ShowListing/USA/New%20York/New%20York"
Set oHtml = New HTMLDocument
With CreateObject("WINHTTP.WinHTTPRequest.5.1")
.Open "GET", URL, False
.send
oHtml.body.innerHTML = .responseText
End With
Set nodeList1 = oHtml.querySelectorAll("div.paid-listing .listing-title")
Set nodeList2 = oHtml.querySelectorAll("div.paid-listing .address-summary")
With Worksheets("Sheet3")
.UsedRange.ClearContents
For i = 0 To nodeList1.Length - 1
.Range("A" & i + 1) = nodeList1.Item(i).innerText
.Range("B" & i + 1) = Split(nodeList2.Item(i).innerText, Chr$(10))(0)
Next i
End With
End Sub
Example output:
Yeah, without an API, this can be very tricky at best, and very inconsistent at worst. For now, you can try the script below.
Sub DumpData()
Set IE = CreateObject("InternetExplorer.Application")
IE.Visible = True
URL = "http://www.funeralhomes.com/go/listing/ShowListing/USA/New%20York/New%20York"
'Wait for site to fully load
IE.Navigate2 URL
Do While IE.Busy = True
DoEvents
Loop
RowCount = 1
With Sheets("Sheet1")
.Cells.ClearContents
RowCount = 1
For Each itm In IE.document.all
If itm.classname Like "*free-listing*" Or itm.classname Like "*paid-listing*" Then
.Range("A" & RowCount) = itm.classname
.Range("B" & RowCount) = Left(itm.innertext, 1024)
RowCount = RowCount + 1
End If
Next itm
End With
End Sub
You probably want some kind of input box to capture the city and state and radius from the user, or capture those variable in cells in your worksheet.
Notice, the '%20' is a space character.
I got this idea from a friend of mine, Joel, a long time ago. That guy is great!
I have a simple excel VBA routine to use template text files and replace key tags in them with values from an Excel array, with variable rows/columns. It works great, and has saved me tons of time for the last couple of years.
Now I need to do the same thing, but read/export a word document.
It's KILLING me. I've tried to follow numerous examples, but all I get is an output file that's the un-modified template pages that I'm using; all the original keywords that I'm searching for, but none of the replacements, even when my debug feed is showing positive hits for all keys.
Public Sub LogicGen(ActiveSheet As String)
On Error Resume Next
DebugMode = True 'Prints some extra data to the debugger window
'Variables
Dim Filename As String
Dim WorkbookPath As String
Dim KeyInput As Variant
Dim i As Integer
Dim END_OF_STORY
Dim MOVE_SELECTION
END_OF_STORY = 6
MOVE_SELECTION = 0
'Activate a worksheet
Worksheets(ActiveSheet).Activate
'Figure out how many keys were entered
i = 2
KeyInput = Cells(6, i)
Do Until IsEmpty(KeyInput)
i = i + 1
KeyInput = Cells(6, i)
Loop
' Key count is the empty address minus 2
KeyCount = i - 2
' push those keys into an array
Dim KeyArray() As String
ReDim KeyArray(0 To KeyCount) As String
For i = LBound(KeyArray) To UBound(KeyArray)
KeyArray(i) = Cells(6, i + 2)
If DebugMode Then
'Debug.Print KeyArray(i)
End If
Next i
'KeyArray now has all of the key values, which will be reused for each of the tags
WorkbookPath = ActiveWorkbook.Path
'Determine how many rows are populated by counting the template cells
TemplateInput = Cells(7, 1)
RowCount = 0
Do Until IsEmpty(TemplateInput)
RowCount = RowCount + 1
TemplateInput = Cells(RowCount + 7, 2)
Loop
OutputFilePath = WorkbookPath & "\" & Cells(1, 2)
'Create an output file
On Error Resume Next
Set OutputApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
Set OutputApp = CreateObject("word.application")
End If
On Error GoTo 0
Set OutputDoc = OutputApp.Documents.Add
Set OutputSelection = OutputApp.Selection
'build a Build a 2D array for the tag values, with the associated
'tag values.
Dim TagArray() As String
ReDim TagArray(0 To RowCount, 0 To KeyCount)
' Step down through all of the rows that have been entered
For i = 0 To RowCount - 1
'Build an array of all of the tags
For KeyIndex = 0 To KeyCount
TagArray(i, KeyIndex) = Cells(i + 7, KeyIndex + 2).Text
If DebugMode Then
'Debug.Print TagArray(i, KeyIndex)
End If
Next KeyIndex
'Ensure template file exists, once per row
Filename = WorkbookPath & "\" & Cells(i + 7, 1).Text
' Check for existance of template file, and open if it exists
If Not FileFolderExists(Filename) Then
MsgBox (Filename & " does not exist")
GoTo EarlyExit
Else
'Grab the template file and push it to the output
Set TemplateApp = CreateObject("word.application")
Set TemplateDoc = TemplateApp.Documents.Open(Filename)
Set TemplateSel = TemplateApp.Selection
TemplateDoc.Range.Select
TemplateDoc.Range.Copy
OutputSelection.endkey END_OF_STORY, MOVE_SELECTION
OutputSelection.TypeParagraph
OutputSelection.Paste
'Clear the template file, since we don't know if it will be the same next time
TemplateDoc.Close
TemplateApp.Quit
Set TemplateApp = Nothing
End If
'Iterate through all of the keys to be replaced
For j = 0 To KeyCount - 1
For Each storyrange In OutputDoc.StoryRanges
Do
With storyrange.Find
.Text = KeyArray(j)
.Replacement.Text = TagArray(i, j)
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
If .Execute(Replace:=wdReplaceAll) Then
Debug.Print "Replacing: " & KeyArray(j) & " With: " & TagArray(i, j)
End If
End With
Set storyrange = storyrange.nextstoryrange
Loop While Not storyrange Is Nothing
Next
Next j
Next i
OutputDoc.SaveAs (OutputFilePath)
EarlyExit:
' Close the files that were opened
OutputDoc.Close
OutputApp.Quit
Set OutputDoc = Nothing
Even though my debug monitor is full of stuff like:
Replacing: %EULow% With: 0
Replacing: %EUHigh% With: 100
Replacing: %AlarmHH% With: No HH
Replacing: %AlarmH% With: No H
Replacing: %AlarmL% With: No L
My output document is still numerous pages of Word tables with the %something% tags not replaced. I'm going mad - I've been working on this all day.
This is where it's breaking down:
For Each storyrange In OutputDoc.StoryRanges
Do
With storyrange.Find
.Text = KeyArray(j)
.Replacement.Text = TagArray(i, j)
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
If .Execute(Replace:=wdReplaceAll) Then
Debug.Print "Replacing: " & KeyArray(j) & " With: " & TagArray(i, j)
End If
End With
Set storyrange = storyrange.nextstoryrange
Loop While Not storyrange Is Nothing
Next
I've tried to do this search and replace probably 7 different ways from different examples, nothing actually replaces the text.
The problem is almost certainly that you are using "late binding" (which is fine), and are not referencing the Word object model, which means that constants defined by the Word Object model such as "wdFindContinue" and "wdReplaceAll" will be "empty". The values in the Word Object model are 1 and 2, respectively.
You can either reference the Word object model (there are advantages and disadvantages of doing so) via VB Editor's Tools->References menu, and reference the constants in it, or define your own constants with the same name and the correct values, or just use the correct constant values.
If you choose to reference the Word Object model, VBA should pick up the Word constant values with no additional qualification, i.e.
debug.print wdReplaceAll
should now display "2" in the Immediate window>
However, some people prefer to spell out the origin of these constants, e.g. via
Word.wdReplaceAll
or to be even more specific
Word.wdReplace.wdReplaceAll
If you want to see the Debug.Print output, you should also delete the first .Execute Replace:=ReplaceAll in your code (because it will then work properly, so the search string will not be found when the second .Execute method is called).
Hello I have this loop that checks weather checkboxes have been checked or not, but the array that this loop creates stores every single checkbox value of the list of checkboxes regardless if it is checked or not. So, I am not sure how to create a second loop that will gather only the checkboxes that have been checked out of the array SelectedItemArray1(i). Thank you very much for your help in advance and this is what I have so far.
For i = 0 To Sheet1.ListBox1.ListCount - 1
If Sheet1.ListBox1.Selected(i) = True Then
SelectedItemArray1(i) = Sheet1.ListBox1.List(i)
End If
MsgBox SelectedItemArray1(i)
Next
Try this (untested) code and see how well it works for you:
Dim Msg As String
Dim i As Integer
If ListBox1.ListIndex = -1 Then
Msg = "Nothing"
Else
Msg = ""
For i = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(i) Then
Msg = Msg & ListBox1.List(i) & vbCrLf
End If
Next i
End If
If your list box allows multi-selection of check boxes, then it's a different kind of animal. I did some googling and found this article, which should hopefully give you some ideas. Also, take a look at this article, which seems more complete.
EDIT:
I thought it might help to give the multi-select code too, from the first article I linked:
Dim i As Long
Dim j As Long
Dim msg As String
Dim arrItems() As String
ReDim arrItems(0 To ListBox1.ColumnCount - 1)
For j = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(j) Then
For i = 0 To ListBox1.ColumnCount - 1
arrItems(i) = ListBox1.Column(i, j)
Next i
msg = msg & Join(arrItems, ",") & vbCrLf & vbCrLf
End If
Next j
MsgBox msg
I have this code that I have tweaked below. I use it to scrape other morningstar data, but I can't seem to make it work now for "expected return" for ETFs(Exchange Traded Funds). Everything on the code right now is set up to get the data that I need but I am having a problem getting it on the excel spreadsheet. When I do a msgBox tblTR under the code:
Set tblTR = Doc.getElementsByClassName("pr_text3")(4).innerText
I get the expected value on the message box.
However, when I take the msgbox code out, the value doesn't appear in the excel spreadsheet. I have been trying to work it out for hours now and need HELP!
Below is the entire code. under tab "Tickers2" is where I have all the tickers I would like to pull data. Examples JKE, JKF, JKD...which I have about 1000. under tab "ExpectedReturn" is where I want the data to be displayed. I think it has to do with me pulling elementsbyclassname versus when I used to pull the elementsbytagname. There wasn't in tagnames in the information i needed so I switched it to class name. Below is the entire code.
I will also mention that you have to be signed in to morningstar.com in order to get the actual data, but I am assuming that the forum can point me in the right direction without needing to be signed in.
The website is www.morningstar.com
Sub ExpectedReturn()
Dim IE As Object, Doc As Object, lastRow As Long, tblTR As Object, tblTD As Object, strCode As String
lastRow = Range("A65000").End(xlUp).Row
Set IE = CreateObject("internetexplorer.application")
IE.Visible = True
last_row = Sheets("Tickers2").Range("A1").End(xlDown).Row
ini_row_dest = 1
Sheets("ExpectedReturn").Select
Sheets("ExpectedReturn").Range("A1:H10000").ClearContents
Application.ScreenUpdating = True
For i = 1 To lastRow
Application.StatusBar = "Updating upDown" & i & "/" & last_row
row_dest = ini_row_dest + (i - 1)
strCode = "Tickers2" ' Range("A" & i).value
list_symbol = Sheets("Tickers2").Range("A" & i)
IE.navigate "http://etfs.morningstar.com/quote?t=" & list_symbol
Do While IE.readyState <> 4: DoEvents: Loop
Set Doc = CreateObject("htmlfile")
Set Doc = IE.document
tryAgain:
Set tblTR = Doc.getElementsByClassName("pr_text3")(4).innerText
MsgBox tblTR
If tblTR Is Nothing Then GoTo tryAgain
On Error Resume Next
j = 2
For Each tblTD In tblTR.getElementsByTagName("td")
tdVal = Split(tblTD.innerText, vbCrLf)
Cells(i, j) = tdVal(0)
Cells(i, j + 1) = tdVal(1)
j = j + 2
Next
Sheets("ExpectedReturn").Range("A" & row_dest).Value = list_symbol
Next i
Range("A3").Select
Application.StatusBar = False
Application.Calculation = xlAutomatic
End Sub
Thank you in advance.
-Eddie
By setting
Set tblTR = Doc.getElementsByClassName("pr_text3")(4).innerText
the variable tblTR is a string. You want a dom element, so remove the .innerText
Only then you can loop over its TD-children further down.
This was my fix
tblTR=Doc.ElementsByClassName("pr_text3)(4).innerText
Sheets("ExpectedReturn").Range("B"& row_dest).Value=tblTR