Web Query from URL in Cell - excel

I believe I have thoroughly researched this question (sorry if you have seen the answer, please be patient with me).
Truly a newcomer to VBA/Macros and do not even fully understand where to "put" the codes that are provided in these message boards, that is why I prefer a formula.
My sheet has cells which feed to a hyperlink (i.e. A1=JFK, B1:CVG, C1=HYPERLINK("http://www.gcmap.com/dist?p="&A1&"-"&B1,"My Flight").
If you visit the link (http://www.gcmap.com/dist?P=jfk-cvg) it shows the flying distance between these two points - 589 mi.
What I am trying to do is do a web query in Excel based off the link provided in cell C1, and then have the web query point to the total distance included in the link - and then populate another cell on my sheet (D1) with that distance.
Any and all help would be appreciated!

How's something like this:
Sub getMiles()
'Thanks to http://stackoverflow.com/questions/16975506/how-to-download-source-code-from-a-website-with-vba for idea
Dim k As Long, s
Dim URL2 As String
Dim ws As Worksheet, newWS As Worksheet
Set ws = ActiveSheet
Application.ScreenUpdating = False
URL2 = ws.Cells(1, 3) 'Cell C1 is the URL
' to get data from the url we need to creat a win Http object_
' tools > references > select Windows Win Http Services 5.1
Dim Http2 As New WinHttpRequest
'open the url
Http2.Open "GET", URL2, False
' send request
Http2.Send
'MsgBox Http2.ResponseText
Debug.Print s
'Debug.Print Http2
Debug.Print URL2
Dim Resp As String: Resp = Http2.ResponseText
Dim Lines2 As Variant: Lines2 = Split(Resp, ">")
Worksheets.Add after:=Sheets(Sheets.Count)
Set newWS = ActiveSheet
newWS.Name = "Temp for source code"
k = 0
For k = LBound(Lines2) To UBound(Lines2)
newWS.Cells(1 + k, 1).Value = Lines2(k)
k = k + 1
Next k
Dim findString As String, stringCell As Range
findString = " mi"
Set stringCell = newWS.Columns(1).Find(what:=findString)
Dim milesFlown As String
milesFlown = Left(stringCell.Value, WorksheetFunction.Search("&", stringCell, 1) - 1)
'MsgBox ("You would fly " & milesFlown)
ws.Cells(1, 4).Value = milesFlown
Application.DisplayAlerts = False
newWS.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
It's sort of roundabout, but what it does is get the source code of your URL, and in that source code, look for a string that only seems to occur before the miles are given (" mi"), then finds the numbers to the left of the &, and sets that as your miles. You will need to tweak the macro to correctly point to the cell with your URL. Let me know if you need any help doing so!
edit: Ah, to use this code, with Excel open, press ALT+F11, this will open up the VB editor. I think you can insert this code (just copy/paste) into the "Sheet1 (Sheet1)" part. If not, you'll need to right click "VBAProject ([yourbook])" and Insert Module, and put the code there. It should then show up in your macro list (View tab --> Macros).
Edit2: Also, you'll need to add a Reference most likely in VBA. Press ALT+F1 to open VB Editor, then in Tools -> References, look for "Microsoft WinHTTP Services, version 5.1" and add a check mark, and click "Ok" to add this reference. Otherwise, you'll get an error.
Edit3: Updated the code. It now puts the source code on a new sheet, so anything you have in Col. A won't be deleted.

Related

VBA partial match

I've been making what started out as a basic asset tracker, but as its progressed more and more has been added.
before this I've never done anything with excel, meaning most of what i have done has been through searching, copying, and making slight changes to code found online.
Im now trying to search for a client name held on a "Database" sheet and display all assets assigned to that client on a "Reports" sheet
I have "Userform5" with a command box auto populating the name of the client as you begin typing
Client name is often referred to differently, so the official client name is loaded into the command box, however on the spreadsheet it may have been inputted as a shortened version of the name. Eg, Tarmac Trading Limited is the official name loaded into the command box, on the Database this may be input as just Tarmac or another slight variation.
i have a code that works fine, but only for exact matches, and will even disregard if a space has been entered at the end of the client name on "database"
is there a way to change the below code to search for partial matches?
Sub ClientSearch_Click()
Application.ScreenUpdating = False
Dim Client As String
Dim finalrow As Integer
Dim i As Integer
Sheets("Reports").Range("A2:aj10000").ClearContents
Client = Trim(Cmbclient.Text)
Sheets("Database").Activate
finalrow = Sheets("Database").Range("A10000").End(xlUp).Row
For i = 2 To finalrow
'Function equalsIgnoreCase(str1 As String, str2 As String) As Boolean
' equalsIgnoreCase = LCase(str1) = LCase(str2)
'End Function
If LCase(Sheets("Database").Cells(i, 4)) = LCase(Client) Then
Range(Cells(i, 1), Cells(i, 50)).Copy
Sheets("Reports").Range("A100").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End If
Next i
Sheets("Reports").Activate
Range("A:AZ").EntireColumn.Hidden = True
Range("B:B,D:D,E:E,F:F,G:G,H:H,I:I,J:J,K:K,L:L,M:M,N:N,Q:Q,AB:AB,AF:AF,AG:AG,AH:AH,AI:AI,AJ:AJ").EntireColumn.Hidden = False
Application.ScreenUpdating = True
Unload UserForm5
End Sub
Replace
If LCase(Sheets("Database").Cells(i, 4)) = LCase(Client) Then
with
If LCase(Sheets("Database").Cells(i, 4)) = LCase(Client) Or InStr(LCase(Client), LCase(Sheets("DataBase"), Cells(i, 4))) > 0 Then

VBA code that reads a txt file, places specified words into columns

I'm trying to write a VBA macro that will read through a text document and place specific words into columns. UPDATE: Here's a sample of the file, apparently it's XML, so at least I learned something new today. So i guess what I need is a program to shed the XML parts, and place just the text into columns.
<Alarm>
<ID>1002</ID>
<Type>Fault</Type>
<Message>Bad Brake</Message>
<Tagname>error.e2</Tagname>
</Alarm>
<Alarm>
<ID>1004</ID>
<Type>Fault</Type>
<Message>No Motion</Message>
<Tagname>error.e4</Tagname>
</Alarm>
<Alarm>
<ID>1005</ID>
<Type>Fault</Type>
<Message>Upper safety door open</Message>
<Tagname>error.e5</Tagname>
</Alarm>
Ultimately, I'm trying to put the 4 digit error codes in column A (i.e. 1002, 1004...), and the error message in column B (i.e. Bad Brake, No motion....). I'll paste what I have so far, I tried coding it for just one pair of data to start. I'm stuck trying to get the error message into column B. The error messages all start in the same position on each line, but I can't figure out how to stop copying the text, since each error message is a different length of characters. Any ideas?
(P.S. - I apologize if the code is terrible, I've been interning as an electrical engineer, so my programming has gotten rather rusty.)
Private Sub CommandButton1_Click()
Dim myFile As String, textLine As String, ID As Integer, error_msg As Integer
myFile = "C:\Users\scholtmn\Documents\Projects\Borg_Warner_txt_file\BW_fault_codes.txt"
Open myFile For Input As #1
Do Until EOF(1)
Line Input #1, textLine
Text = Text & textLine
Loop
Close #1
ID = InStr(Text, "<ID>")
error_msg = InStr(Text, "<Message>")
Range("A1").Value = Mid(Text, ID + 4, 4)
Range("B1").Value = Mid(Text, error_msg + 9, (InStr(Text, " <") - 31))
End Sub
Please, try the next code:
Sub ExtractErrorsDefinition()
'it needs a reference to 'Microsoft XML, v6.0'
Dim XMLFileName As String, oXMLFile As New MSXML2.DOMDocument60, sh As Worksheet
Dim N As MSXML2.IXMLDOMNode, i As Long, arr
Set sh = ActiveSheet 'use here the necessary sheet
XMLFileName = "the full text file path" '"C:\Utile\Teste Corel\XMLtext.txt"
oXMLFile.Load (XMLFileName)
ReDim arr(1 To oXMLFile.SelectNodes("AlarmDictionary/Alarm").length, 1 To 2): i = 1
For Each N In oXMLFile.SelectNodes("AlarmDictionary/Alarm")
arr(i, 1) = N.SelectSingleNode("ID").Text: arr(i, 1) = N.SelectSingleNode("Message").Text: i = i + 1
Next
sh.Range("A2").Resize(UBound(arr), 2).value = arr
End Sub
It may work using late binding, but it is better to have the intellisense suggestion, especially when not very well skilled in working with XML.
If looks complicated to add such a reference, I can add a piece of code to automatically add it.
Please, run the next code to automatically add the necessary reference. Save your workbook and run the first code after:
Sub addXMLRef()
'Add a reference to 'Microsoft Scripting Runtime':
'In case of error ('Programmatic access to Visual Basic Project not trusted'):
'Options->Trust Center->Trust Center Settings->Macro Settings->Developer Macro Settings->
' check "Trust access to the VBA project object model"
Application.VBE.ActiveVBProject.References.AddFromFile "C:\Windows\System32\msxml6.dll"
End Sub
It looks like the txt file you are using is actually an xml file. If you changed the format, this piece of code I slightly adjusted from here should work fine.
Sub From_XML_To_XL()
Dim xmlWb As Workbook, xSWb As Workbook, xStrPath$, xfdial As FileDialog, _
xFile$, lr%, first As Boolean, r As Range
first = True
Set xfdial = Application.FileDialog(msoFileDialogFilePicker)
xfdial.AllowMultiSelect = False
xfdial.Title = "Select an XML File"
If xfdial.Show = -1 Then xStrPath = xfdial.SelectedItems(1) & ""
If xStrPath = "" Then Exit Sub
Set xSWb = ThisWorkbook
lr = xSWb.ActiveSheet.Range("a" & Rows.Count).End(xlUp).Row ' last used row, column A
xFile = xStrPath
Set xmlWb = Workbooks.OpenXML(xFile)
If first Then
Set r = xmlWb.Sheets(1).UsedRange ' with header
Else
xmlWb.Sheets(1).Activate
Set r = ActiveSheet.UsedRange
Set r = Range(Cells(3, 1), Cells(r.Rows.Count, r.Columns.Count))
End If
r.Copy xSWb.ActiveSheet.Cells(lr + 1, 1)
lr = xSWb.ActiveSheet.Range("a" & Rows.Count).End(xlUp).Row
xmlWb.Close False
first = False
End Sub
I think you'll find this task a lot easier if you take advantage of the fact it is in XML format. You can find more information about working with XML in VBA here.
As Ben Mega already stated: you have an XML-File - why not use XML-functionality.
Add "Microsoft XML, v6.0" to your project references - then you can use this code
Public Sub insertTextFromXML()
Dim objXML As MSXML2.DOMDocument60
Set objXML = New MSXML2.DOMDocument60
If Not objXML.Load("T:\Stackoverflow\Test.xml") Then
Err.Raise objXML.parseError.ErrorCode, , objXML.parseError.reason
End If
Dim nAlarm As MSXML2.IXMLDOMNode
'loop through all alarms and output ID plus message
For Each nAlarm In objXML.SelectNodes("AlarmDictionary/Alarm")
With nAlarm
Debug.Print .SelectSingleNode("ID").Text, .SelectSingleNode("Message").Text
End With
Next
'Filter for ID 1004
Set nAlarm = objXML.SelectSingleNode("AlarmDictionary/Alarm[ID=1004]")
Debug.Print nAlarm.XML
End Sub
You can google for VBA XPath to find out how to access the various values.

Excel macro to search a website with excel data and extract specific results and then loop for next value for another webiste

I have replicated the code in Excel macro to search a website with excel data and extract specific results and then loop for next value, although I get a error on the line URL_Get_SKU_Query1 = entityRange.Offset(0, 1).Value2 stating "object variable or with block variable not set"
So I am just trying to replicate the code for another website.
This code pulls in a certain text and spits out a value from the webiste.
So I would like to enter in MFR SKU in sheet 1 as such:
Name // SKU // Price
WaterSaverFaucet // SS902BC
After I have created a macro button on sheet 2 and clicking it
Then have it spit out the price.
So that it ends up like this below:
Name // SKU // Price
WaterSaverFaucet // SS902BC // 979.08
I would need this in order to look up multiple items on a website.
Sub LoopThroughBusinesses1()
Dim i As Integer
Dim SKU As String
For i = 2 To Sheet1.UsedRange.Rows.Count
SKU = Sheet1.Cells(i, 2)
Sheet1.Cells(i, 3) = URL_Get_SKU_Query1(SKU)
Next i
End Sub
Function URL_Get_SKU_Query1(strSearch As String) As String ' Change it from a Sub to a Function that returns the desired string
' strSearch = Range("a1") ' This is now passed as a parameter into the Function
Dim entityRange As Range
With Sheet2.QueryTables.Add( _
Connection:="URL;https://www.neobits.com/SearchBySKU.aspx?SearchText=" & strSearch & "&safe=active", _
Destination:=Sheet2.Range("A1")) ' Change this destination to Sheet2
.BackgroundQuery = True
.TablesOnlyFromHTML = True
.Refresh BackgroundQuery:=False
.SaveData = True
End With
' Find the Range that has "Price"
Set entityRange = Sheet2.UsedRange.Find("Price")
' Then return the value of the cell to its' right
URL_Get_SKU_Query1 = entityRange.Offset(0, 1).Value2
' Clear Sheet2 for the next run
Sheet2.UsedRange.Delete
End Function
Your logic is flawed unfortunately. You cannot simply take the mechanism from one webpage and assume it works for the next. In this case the solution you are trying will not work. When you enter a SKU into search what actually happens is a page re-direct (302). Not the construction of an url as you have tried. You are getting the error you see primarily due to hitting a page not found - though surfaces due to your element not being found on the 404 page.
Instead, you can use the construct the page in question actually uses for initial url and then you can use xmlhttp which will follow the re-direct as follows:
VBA:
Option Explicit
Public Sub GetPrices()
Dim xhr As XMLHTTP60, html As HTMLDocument, ws As Worksheet, i As Long
Set ws = ThisWorkbook.Worksheets("Sheet1")
Set xhr = New XMLHTTP60
Set html = New HTMLDocument
Dim allData()
allData = ws.UsedRange.Value
With xhr
For i = 2 To UBound(allData, 1)
.Open "GET", "https://www.neobits.com/search?keywords=" & allData(i, 2), False
.send
Dim price As Object
html.body.innerHTML = .responseText
Set price = html.querySelector("#main_price")
If Not price Is Nothing Then
allData(i, 3) = price.innerText
Else
allData(i, 3) = "No price found"
End If
Set price = Nothing
Next
End With
ws.Cells(1, 1).Resize(UBound(allData, 1), UBound(allData, 2)) = allData
End Sub
I assume your page set-up, in Sheet1, is as follows:
Required project references:
The two references bounded in red are required. Press Alt+F11 to open the VBE and then go Tools > References and add references. You may have a different version number for xml library - in which case reference will need changing as will code references of
Dim xhr As XMLHTTP60
and
New XMLHTTP60
To run this code:
Press Alt+F11 to open the VBE > Right click in project explorer > Add standard module. Paste code into that standard module > Select anywhere inside the code and press F5, or hit the green Run arrow in the ribbon.
You could further develop, for example, to handle non 200 status codes:
Option Explicit
Public Sub GetPrices()
Dim xhr As XMLHTTP60, html As HTMLDocument, ws As Worksheet, i As Long
Set ws = ThisWorkbook.Worksheets("Sheet1")
Set xhr = New XMLHTTP60
Set html = New HTMLDocument
Dim allData(), price As Object
allData = ws.UsedRange.Value
With xhr
For i = 2 To UBound(allData, 1)
.Open "GET", "https://www.neobits.com/search?keywords=" & allData(i, 2), False
.send
If .Status <> 200 Then
allData(i, 3) = "Status not succeeded" '<== Little bit loose but you get the idea.
Else
html.body.innerHTML = .responseText
Set price = html.querySelector("#main_price")
If Not price Is Nothing Then
allData(i, 3) = price.innerText
Else
allData(i, 3) = "No price found"
End If
Set price = Nothing
End If
Next
End With
ws.Cells(1, 1).Resize(UBound(allData, 1), UBound(allData, 2)) = allData
End Sub
' Find the Range that has "Entity Type:"
Set entityRange = Sheet2.UsedRange.Find("Lists At:")
' Then return the value of the cell to its' right
URL_Get_SKU_Query1 = entityRange.Offset(0, 1).Value2
The problem is that Range.Find may not find what you're looking for, for various reasons. Always specify the optional parameters to that function, since it otherwise "conveniently remembers" the values from the last time it was invoked - either from other VBA code, or through the Excel UI (IOW there's no way to be 100% sure of what values it's going to be running with if you don't specify them). But even then, if Range.Find doesn't find what it's looking for, it will return Nothing - and you can't just assume that will never happen!
But, reading closer...
' Find the Range that has "Entity Type:"
Set entityRange = Sheet2.UsedRange.Find("Lists At:")
Someone's lying. Read the comment. Now read the code. Who's telling the truth? Don't write comments that say "what" - have comments say "why", and let the code say "what". Otherwise you have situations like that, where it's impossible to tell whether the comment is outdated or the code isn't right, at least not without looking at the worksheet.
In any case, you need to make sure entityRange isn't Nothing before you try to make a member call against it:
If Not entityRange Is Nothing Then
URL_Get_SKU_Query1 = entityRange.Offset(0, 1).Value2
End If

How to record API Ticker data in an Excel table

I have no VBA experience so I am hoping that there is a way to do this without use of macros or programming - If there isn't then help with code and explaining what it is doing, so I can learn from it, would be very much appreciated. :)
I am using a daily refreshed API ticker which gives me a date and a value.
I then have a table predefined for the year, 01/01/18 > 31/12/18 (for example), adjacent to a cell for the value.
I’ve used vlookup to populate the value on the given day, but obviously in this current state, the data is not recordable, so when the date on the API changes from 01/01/18 to 02/01/18 the value is lost and it moves onto the next specified cell to fill.
Is there a way to record/ store this data – Make it non external automatically? Without copy/paste text or value manually?
The data you are fetching from that API is JSON. Unfortunately support for JSON in VBA is 100% non-existent. There are some folks that have made some libraries, but since you are new to VBA, and the JSON response is very very small, I think it's best to just treat the response from the API as a string and get the stuff we need by parsing the string.
An example of what this would look like for that URL (appending whatever is fetched to Sheet1 columns A, B, C, and D:
Sub getTickerValue()
'Get the data from the API
Dim strResponse As String: strResponse = LoadHTML("https://api.fixer.io/latest?symbols=USD,GBP")
'Since we aren't actually going to parse the json because it's not well supported in VBA
' we will instead remove everything we don't care about and parse the results
' So replace out double quotes and squirrely braces (Not a great idea for more complex json)
strResponse = Replace(strResponse, Chr(34), "")
strResponse = Replace(strResponse, "}", "")
strResponse = Replace(strResponse, "{", "")
'Load up each item into an array splitting on comma
Dim jsonArray As Variant: jsonArray = Split(strResponse, ",")
'Loop the array, sniff for the data we want, and toss it in it's respective variable
Dim strBase As String, strDate As String, strRate1 As String, strRate2 As String
For Each elem In jsonArray
If Split(elem, ":")(0) = "base" Then strBase = Split(elem, ":")(1)
If Split(elem, ":")(0) = "date" Then strDate = Split(elem, ":")(1)
If Split(elem, ":")(0) = "rates" Then strRate1 = Split(elem, ":")(2)
If Split(elem, ":")(0) = "USD" Then strRate2 = Split(elem, ":")(1)
Next elem
'Set up the range where we will output this by starting at cell A99999
' in Sheet1 and going up until we hit the first occupied cell
' offset by 1 row to get the first unoccupied cell
Dim outRange As Range
Set outRange = Sheet1.Range("A99999").End(xlUp).Offset(1)
'Now we know the last unoccupied cell in Sheet1, go ahead and dump the data
outRange.Value = strBase
outRange.Offset(, 1).Value = strDate
outRange.Offset(, 2).Value = strRate1
outRange.Offset(, 3).Value = strRate2
End Sub
Function LoadHTML(xmlurl) As String
'Using the XMLHTTP library to get the results since monkeying with IE is ugly and painful
Dim xmlhttp
Set xmlhttp = CreateObject("MSXML2.XMLHTTP")
xmlhttp.Open "GET", xmlurl, False
' switch to manual error handling
On Error Resume Next
xmlhttp.Send
If Err.Number <> 0 Then
WScript.Echo xmlhttp.parseError.Reason
Err.Clear
End If
' switch back to automatic error handling
On Error GoTo 0
LoadHTML = xmlhttp.responseText
End Function
This isn't exactly what you are looking for, but I think it's close enough to get you in the ballpark. You can run it by creating a button or shape on the sheet and then pointing that at the "GetTickerValue" macro. Alternatively after pasting this in a new VBA Module you can stick your cursor in the GetTicketValue block of code and hitting the play button at the top (or F5). It will fetch the data and append it to whatever your Sheet1 is.

Automation Error -2147221080 (800401a8)

Im intending to conduct a VBA macro which returns the cell value of C34 of the file referenced by path which has the sheet names as presented in myHeadings.
Sub Test()
Dim myHeadings() As String
Dim i As Long
Dim path As String
path = "C:\pathtofile\file.xlsx"
Dim currentWb As Workbook
Set currentWb = ActiveWorkbook
Dim openWb As Workbook
Set openWb = Workbooks.Open(path)
Dim openWs As Worksheet
myHeadings = Split("Januari,Februari,Mars", ",")
For i = 0 To UBound(myHeadings)
Set openWs = openWb.Sheets(myHeadings(i))
currentWb.Sheets("Indata").Range("AA" & 73+Application.Match (myHeadings(i),Array,False)).Value = openWs.Range("C34").Value
Next i
End Sub
This however gives the error message: Automation Error -2147221080 (800401a8) at the code snippet:
currentWb.Sheets("Indata").Range("AA73+Application.Match (i,Array,False)").Value = openWs.Range("C34").Value
I'm new to VBA and am yet to create a macro actually runable, so the cause may be trivial. From googling I'm yet to find a solution to this specific problematic.
EDITED some code to remove "Array" and updated t
I think you want this:
currentWb.Sheets("Indata").Range("AA" & 73 + Application.Match(i,Array,False)) = openWs.Range("C34")
If the result of
Application.Match(i,Array,False)
is equal to 1, you want to make AA74 to equal whatever is in openws.Range("C34"), right?
'&' is a concatentation character, so what we are saying above is that we take "AA" then calculate 73 + 1 and concatenate it to the end. The bit you were missing is escaping the text after the "AA" to do the numerical calculation.
EDIT:-
After reading Aiken's comments above, I believe your answer should be to remove the Match function entirely:
currentWb.Sheets("Indata").Range("AA" & 73 + i + 1).Value = openWs.Range("C34").Value

Resources