excel vba http request download data from yahoo finance - excel

I am in the process of making a program I wrote using excel vba faster.
The program downloads stock market data from the asx.
I want to get data from 2 urls:
MY CODE
url2 = "http://ichart.finance.yahoo.com/table.txt?s=bhp.ax"
Set XMLHTTP = CreateObject("WinHttp.WinHttpRequest.5.1")
XMLHTTP.Open "GET", url2, False
XMLHTTP.send
result = XMLHTTP.responseText
ActiveCell.Value = result
Set XMLHTTP = Nothing
URL 1. http://ichart.finance.yahoo.com/table.txt?s=bhp.ax
MY PROBLEM.
This file is very large. I thought I could simply store the result of these http requests and print it to the debug window or directly to a cell. However these methods seem to be cutting off parts of the data?
if I download the txt file from url 2 in notepad++ it has almost 200 000 characters
but it excel it has between 3 -5 000. What is the best way to handle these requests so that all the data is captured and I can parse it all later?
URL 2. from the first URL I only want the JSON data which results from the YQL query.
MY PROBLEM
I am not sure how to get just the json data when you follow the link below, and or how to store it so that the problem experienced with URL 1 (missing data) does not occur.
http://developer.yahoo.com/yql/console/?q=select%20symbol%2C%20ChangeRealtime%20from%20yahoo.finance.quotes%20where%20symbol%20in%20%28%22YHOO%22%2C%22AAPL%22%2C%22GOOG%22%2C%22MSFT%22%29%20|%20sort%28field%3D%22ChangeRealtime%22%2C%20descending%3D%22true%22%29%0A%09%09&env=http%3A%2F%2Fdatatables.org%2Falltables.env#h=select%20*%20from%20yahoo.finance.quotes%20where%20symbol%20in%20%28%22bhp.ax%22%29
Many Thanks, Josh.

Try this revised code
Sub GetYahooFinanceTable()
Dim sURL As String, sResult As String
Dim oResult As Variant, oData As Variant, R As Long, C As Long
sURL = "http://ichart.finance.yahoo.com/table.txt?s=bhp.ax"
Debug.Print "URL: " & sURL
sResult = GetHTTPResult(sURL)
oResult = Split(sResult, vbLf)
Debug.Print "Lines of result: " & UBound(oResult)
For R = 0 To UBound(oResult)
oData = Split(oResult(R), ",")
For C = 0 To UBound(oData)
ActiveSheet.Cells(R + 1, C + 1) = oData(C)
Next
Next
Set oResult = Nothing
End Sub
Function GetHTTPResult(sURL As String) As String
Dim XMLHTTP As Variant, sResult As String
Set XMLHTTP = CreateObject("WinHttp.WinHttpRequest.5.1")
XMLHTTP.Open "GET", sURL, False
XMLHTTP.Send
Debug.Print "Status: " & XMLHTTP.Status & " - " & XMLHTTP.StatusText
sResult = XMLHTTP.ResponseText
Debug.Print "Length of response: " & Len(sResult)
Set XMLHTTP = Nothing
GetHTTPResult = sResult
End Function
This will split up the data into Rows so the max text length are not reached in a cell. Also this have further split the data with commas into corresponding columns.

You may like to try following code from http://investexcel.net/importing-historical-stock-prices-from-yahoo-into-excel/
I just modify the qurl variable to your url and it work, it pouring 4087 line of data to my excel sheet, nicely formatted without any problem.
Just name your sheet1 as Data.
Sub GetData()
Dim DataSheet As Worksheet
Dim EndDate As Date
Dim StartDate As Date
Dim Symbol As String
Dim qurl As String
Dim nQuery As Name
Dim LastRow As Integer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Sheets("Data").Cells.Clear
Set DataSheet = ActiveSheet
' StartDate = DataSheet.Range("startDate").Value
' EndDate = DataSheet.Range("endDate").Value
' Symbol = DataSheet.Range("ticker").Value
' Sheets("Data").Range("a1").CurrentRegion.ClearContents
' qurl = "http://ichart.finance.yahoo.com/table.csv?s=" & Symbol
' qurl = qurl & "&a=" & Month(StartDate) - 1 & "&b=" & Day(StartDate) & _
' "&c=" & Year(StartDate) & "&d=" & Month(EndDate) - 1 & "&e=" & _
' Day(EndDate) & "&f=" & Year(EndDate) & "&g=" & Sheets("Data").Range("a1") & "&q=q&y=0&z=" & _
' Symbol & "&x=.csv"
qurl = "http://ichart.finance.yahoo.com/table.txt?s=bhp.ax"
Debug.Print qurl
QueryQuote:
With Sheets("Data").QueryTables.Add(Connection:="URL;" & qurl, Destination:=Sheets("Data").Range("a1"))
.BackgroundQuery = True
.TablesOnlyFromHTML = False
.Refresh BackgroundQuery:=False
.SaveData = True
End With
Sheets("Data").Range("a1").CurrentRegion.TextToColumns Destination:=Sheets("Data").Range("a1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=True, Space:=False, other:=False
Sheets("Data").Columns("A:G").ColumnWidth = 12
LastRow = Sheets("Data").UsedRange.Row - 2 + Sheets("Data").UsedRange.Rows.Count
Sheets("Data").Sort.SortFields.Add Key:=Range("A2"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With Sheets("Data").Sort
.SetRange Range("A1:G" & LastRow)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
.SortFields.Clear
End With
End Sub
(the above is not my code, it was taken from the excel file they posted on investexcel.net link above)

Related

Insert Looped Text Pulled from Excel into Email Body

#Niton solved my first question for me, which was how to pull in data from an Excel file in a way that would loop through until a new email address was found. It allows me to take data from multiple lines (and a couple fields on those lines) and place it into an Outlook email.
My problem now is that when it does so, I need it to be included in the body of an email. So there would be some text such as a greeting, then 'you have these vouchers that we need paid off, please...EXCEL DATA HERE...Thank you for looking at this, here is the address you can send to, and if you need to update us, email us back'. That wording is not complete and will be changed, but that is the general idea...getting the Excel text into the body of the email. I have added some fields that are pulled to the strVoucher as shown in the code.
I have tried different iterations as at first the Excel info would just repeat along with the text over and over. I then was able to separate at least part of the email code so that it would put in the first greeting piece of text, but then I am stuck in trying to get it to add more text after the Excel data without repeating all the text over and over. I tried to add another 'With Outmail' section after the strVoucher piece is added, but that just overrode the whole email.
Here is my code as it stands now. Thanks #niton!
Option Explicit
Sub oneEmail_SortedEmailAddresses()
Dim OutApp As Object
Dim OutMail As Object
Dim strVoucher As String
Dim lr As Long
Set OutApp = CreateObject("Outlook.Application")
lr = ActiveSheet.UsedRange.Rows.Count
Dim toAddress As String
Dim i As Long
Dim refundDescYes As Boolean
Dim sigString As String
Dim strbody As String
Dim strname As String
Dim strname2 As String
Dim strCheckNbr As String
Dim strCheckDate As String
Dim strCheckAmt As String
Dim strCheckTst As String
Rows("1:6").Select
Selection.Delete
Range("A1:N1").Select
Selection.AutoFilter
ActiveWorkbook.Worksheets("Check Reconciliation Status").AutoFilter.Sort. _
SortFields.Clear
ActiveWorkbook.Worksheets("Check Reconciliation Status").AutoFilter.Sort. _
SortFields.Add2 key:=Range("A1"), SortOn:=xlSortOnValues, Order:= _
xlAscending, DataOption:=xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("Check Reconciliation Status").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Rows("2:5").Select
Selection.Delete Shift:=xlUp
Range("i2") = "Yes"
Range("I2").AutoFill Destination:=Range("I2:I" & lr)
For i = 2 To lr
Set OutApp = CreateObject("Outlook.Application")
'sigString = Environ("appdata") &
'"\Microsoft\Signatures\Uncashed Checks.htm"
' If Dir(sigString) <> "" Then
' signature = GetBoiler(sigString)
' Else
' signature = ""
' End If
' Select Case Time
' Case 0.25 To 0.5
' GreetTime = "Good morning"
' Case 0.5 To 0.71
' GreetTime = "Good afternoon"
' Case Else
' GreetTime = "Good evening"
' End Select
' Email address
If ActiveSheet.Range("N" & i).Value <> "" Then
' One email per email address
' This assumes the addresses are sorted
If ActiveSheet.Range("N" & i).Value <> toAddress Then
If Not OutMail Is Nothing Then
If refundDescYes = True Then
OutMail.display
Else
OutMail.Close 1 ' olDiscard
End If
End If
toAddress = ActiveSheet.Range("N" & i).Value
Debug.Print toAddress
Set OutMail = Nothing
refundDescYes = False
Set OutMail = OutApp.CreateItem(0)
With OutMail
strname = Cells(i, "A").Value
strname2 = strname
If InStr(Cells(i, "A"), ",") Then strname2 = Trim(Split(strname, ",")(1))
.To = toAddress
.Subject = "Open Vouchers"
strbody = "<Font face = TimesNewRoman p style=font-size:18.5px color = #0033CC)<br><br>You are receiving this email because our records show you have vouchers open as follows: " & _
"<br><br>Voucher #: " & strVoucher & _
"<br>Check Date: " & strCheckDate & _
"<br>Check Amount: " & strCheckAmt
.HTMLBody = "<Font face = TimesNewRoman p style=font-size:26.5px color = #0033CC><B><p style=font-size:18.5px>Dear " & strname2 & ", " & strbody & "<br>"
.HTMLBody = "<B><br><br>Please reply to this email with any questions." & _
"<br><br>***If we do not receive a reply from you within the next 30 days, you will not be paid."
End With
End If
' Refund Desc
If ActiveSheet.Range("I" & i).Value = "Yes" Then
refundDescYes = True
' Voucher
strCheckTst = "Check Number "
strCheckNbr = Cells(i, "K").Value
strVoucher = strCheckTst & Cells(i, "D").Value & " " & Cells(i, "K").Value
strCheckDate = Cells(i, "L").Value
strCheckAmt = Cells(i, "H").Value
With OutMail
.HTMLBody = .HTMLBody & "<br>" & strVoucher
End With
End If
End If
Next
If Not OutMail Is Nothing Then
If refundDescYes = True Then
OutMail.display
Else
OutMail.Close 1 ' olDiscard
End If
End If
Set OutMail = Nothing
Debug.Print "Done."
End Sub
This example below probably will not work because you didn't post a copy of your data on the worksheet, so I had to make some assumptions. Use this as an example of how to organize your code.
Your main issue is the organization of your code, both inside and outside your loop. In my example, I've simplified the main logic by pulling big blocks of code out into other routines. This should make the overall "flow" of your code easier to read and work with.
Notice a couple things:
Always fully qualify your references to ranges, worksheets, and workbooks.
Avoid magic numbers
Rework the code below into your own data and see if it helps.
EDIT: to send only one email per vendor
Option Explicit
Const NAME_COL As Long = 1
Const VOUCHER_COL As Long = 4
Const DATE_COL As Long = 12
Const CHKNUM_COL As Long = 11
Const AMT_COL As Long = 8
Const TOADDR_COL As Long = 14
Sub Example()
Dim statusWS As Worksheet
Set statusWS = ThisWorkbook.Sheets("Check Reconciliation Status")
' PrepareData statusWS
'--- only do this once
Dim outlookApp As Outlook.Application
Set outlookApp = AttachToOutlookApplication
Dim addresses As Dictionary
Set addresses = GetEmailAddresses(statusWS)
Dim emailAddr As Variant
For Each emailAddr In addresses
'--- create the email now that everything is ready
Dim email As Outlook.MailItem
Set email = outlookApp.CreateItem(olMailItem)
With email
.To = emailAddr
.Subject = "Open Vouchers"
.HTMLBody = BuildEmailBody(statusWS, addresses(emailAddr))
'--- send it now
' (if you want to send it later, you have to
' keep track of all the emails you create)
'.Send
End With
Next emailAddr
End Sub
Sub PrepareData(ByRef ws As Worksheet)
With ws
.Rows("1:6").Delete
.Range("A1:N1").AutoFilter
.AutoFilter.Sort.SortFields.Clear
.AutoFilter.Sort.SortFields.Add2 Key:=Range("A1"), SortOn:=xlSortOnValues, Order:= _
xlAscending, DataOption:=xlSortTextAsNumbers
With .AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'.Rows("2:5").Delete Shift:=xlUp
.Range("i2") = "Yes"
'--- it only makes sense to find the last row after all the
' other prep and deletions are complete
Dim lastRow As Long
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range("I2").AutoFill Destination:=Range("I2:I" & lastRow)
End With
End Sub
Function GetEmailAddresses(ByRef ws As Worksheet) As Dictionary
Dim addrs As Dictionary
Set addrs = New Dictionary
With ws
Dim lastRow As Long
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
'--- each entry in the dictionary is keyed by the email address
' and the item value is a CSV list of row numbers
Dim i As Long
For i = 2 To lastRow
Dim toAddr As String
toAddr = .Cells(i, TOADDR_COL).Value
If addrs.Exists(toAddr) Then
Dim theRows As String
theRows = addrs(toAddr)
addrs(toAddr) = addrs(toAddr) & "," & CStr(i)
Else
addrs.Add toAddr, CStr(i)
End If
Next i
End With
Set GetEmailAddresses = addrs
End Function
Function BuildEmailBody(ByRef ws As Worksheet, _
ByRef rowNumbers As String) As String
Const body1 As String = "<Font face = TimesNewRoman p style=font-size:18.5px color = " & _
"#0033CC)"
Const body2 As String = "<Font face = TimesNewRoman p style=font-size:18.5px color = " & _
"#0033CC)<br><br>You are receiving this email because our " & _
"records show you have vouchers open as follows: "
Const body3 As String = "<B><br><br>Please reply to this email with any questions." & _
"<br><br>***If we do not receive a reply from you within " & _
"the next 30 days, you will not be paid.<br><br>"
With ws
Dim rowNum As Variant
rowNum = Split(rowNumbers, ",")
Dim body As String
body = body1 & TimeOfDayGreeting & .Cells(rowNum(LBound(rowNum)), NAME_COL) & "," & body2
Dim i As Long
For i = LBound(rowNum) To UBound(rowNum)
body = body & "<br><br>Voucher #: " & .Cells(rowNum(i), VOUCHER_COL)
body = body & "<br>Check Date: " & Format(.Cells(rowNum(i), DATE_COL), "dd-mmm-yyyy")
body = body & "<br>Check Amount: " & Format(.Cells(rowNum(i), AMT_COL), "$#,##0.00")
Next i
End With
body = body & body3 & EmailSignature
BuildEmailBody = body
End Function
Function EmailSignature() As String
' Dim sigCheck As String
' sigCheck = Environ("appdata") & "\Microsoft\Signatures\Uncashed Checks.htm"
'
' If Dir(sigCheck) <> vbNullString Then
' EmailSignature = GetBoiler(sigString)
' Else
EmailSignature = vbNullString
' End If
End Function
Function TimeOfDayGreeting() As String
Select Case Time
Case 0.25 To 0.5
TimeOfDayGreeting = "Good morning "
Case 0.5 To 0.71
TimeOfDayGreeting = "Good afternoon "
Case Else
TimeOfDayGreeting = "Good evening "
End Select
End Function
Public Function OutlookIsRunning() As Boolean
'--- quick check to see if an instance of Outlook is running
Dim msApp As Object
On Error Resume Next
Set msApp = GetObject(, "Outlook.Application")
If Err > 0 Then
'--- not running
OutlookIsRunning = False
Else
'--- running
OutlookIsRunning = True
End If
End Function
Public Function AttachToOutlookApplication() As Outlook.Application
'--- finds an existing and running instance of Outlook, or starts
' the application if one is not already running
Dim msApp As Outlook.Application
On Error Resume Next
Set msApp = GetObject(, "Outlook.Application")
If Err > 0 Then
'--- we have to start one
' an exception will be raised if the application is not installed
Set msApp = CreateObject("Outlook.Application")
End If
Set AttachToOutlookApplication = msApp
End Function

If statement help on macro VBA

Dim sDate As Date, eDate As Date, sTime As Date, eTime As Date
sTime = Sheet2.[B3]
eTime = Sheet2.[B4]
If sTime > eTime Then
Call pullInferred_Time(Sheet2.[B1], Sheet2.[B2], Sheet2.[B3], Sheet2.[B4], "Inferred_Time")
Call pullPPR(Sheet2.[B1], Sheet2.[B2], Sheet2.[B3], Sheet2.[B4])
Call pullPod_Gaps(Sheet2.[B1], Sheet2.[B8], Sheet2.[B5], Sheet2.[B6])
Call pullOOWA(Sheet2.[B1], Sheet2.[B8], Sheet2.[B5], Sheet2.[B6])
Call pullKiva_Scout(Sheet2.[B1], Sheet2.[B8], Sheet2.[B5], Sheet2.[B6])
Else
Call pullInferred_Time(Sheet2.[B1], Sheet2.[B2], Sheet2.[B3], Sheet2.[B4], "Inferred_Time")
Call pullPPR(Sheet2.[B1], Sheet2.[B2], Sheet2.[B3], Sheet2.[B4])
Call pullPod_Gaps(Sheet2.[B1], Sheet2.[B2], Sheet2.[B5], Sheet2.[B6])
Call pullOOWA(Sheet2.[B1], Sheet2.[B2], Sheet2.[B5], Sheet2.[B6])
Call pullKiva_Scout(Sheet2.[B1], Sheet2.[B2], Sheet2.[B5], Sheet2.[B6])
Sub pullPod_Gaps(sDate, eDate, sTime, eTime)
Dim H As New WinHttp.WinHttpRequest
Dim dataobj As New MSForms.DataObject
Dim URL As String
Dim html As New HTMLDocument
Dim htmlMetricTotals As HTMLHtmlElement
Dim htmlTable As HTMLHtmlElement
Dim htmlTBody As HTMLHtmlElement
Dim htmlTR As HTMLHtmlElement
Dim i As Integer
On Error Resume Next
i = 2
'sDate = ConvertFromLocalTimezoneToUTC(sDate)
'eDate = ConvertFromLocalTimezoneToUTC(eDate)
'sDate = toUnix(sDate)
'eDate = toUnix(eDate)
URL = "https://roboscout.amazon.com/view_plot_data/?sites=(LGB3" _
& ")&current_day=false&startDateTime=" & Format(sDate, "yyyy-mm-dd") _
& Format(sTime, "+hh%3A") _
& Format(sTime, "nn%3A00") _
& "&endDateTime=" & Format(eDate, "yyyy-mm-dd") _
& Format(eTime, "+hh%3A") _
& Format(eTime, "nn%3A00") _
& "&mom_ids=1443&osm_ids=977&oxm_ids=1131&ofm_ids=602&viz=nvd3Table&instance_id=0&object_id=20990&BrowserTZ=America%2FLos_Angeles&app_name=RoboScout&mode=CSV"
Debug.Print URL
H.SetAutoLogonPolicy 0
H.SetTimeouts 0, 0, 0, 0
H.Open "GET", URL, False
H.SetClientCertificate "CURRENT_USER\MY\" & Environ("USERNAME")
H.setRequestHeader "Cookie", VBAMidway_v1()
H.send
H.WaitForResponse
Debug.Print H.Status
Debug.Print H.responseText
dataobj.SetText H.responseText
dataobj.PutInClipboard
With Sheets("Pod_Gaps")
.Activate
.Cells.Clear
.Cells(1, 1).Select
.PasteSpecial Format:="Text", link:=False, DisplayAsIcon:=False, NoHTMLFormatting:=True
.Columns("A:A").TextToColumns DataType:=xlDelimited, ConsecutiveDelimiter:=False, Comma:=True, Space:=False
End With
End Sub
Sub pullOOWA(sDate, eDate, sTime, eTime)
Dim H As New WinHttp.WinHttpRequest
Dim dataobj As New MSForms.DataObject
Dim URL As String
Dim html As New HTMLDocument
Dim htmlMetricTotals As HTMLHtmlElement
Dim htmlTable As HTMLHtmlElement
Dim htmlTBody As HTMLHtmlElement
Dim htmlTR As HTMLHtmlElement
Dim i As Integer
On Error Resume Next
i = 2
'sDate = ConvertFromLocalTimezoneToUTC(sDate)
'eDate = ConvertFromLocalTimezoneToUTC(eDate)
'sDate = toUnix(sDate)
'eDate = toUnix(eDate)
URL = "https://roboscout.amazon.com/view_plot_data/?sites=(LGB3" _
& ")&startDateTime=" & Format(sDate, "yyyy-mm-dd") _
& Format(sTime, "+hh%3A") _
& Format(sTime, "nn%3A00") _
& "&endDateTime=" & Format(eDate, "yyyy-mm-dd") _
& Format(eTime, "+hh%3A") _
& Format(eTime, "nn%3A00") _
& "&mom_ids=2170%2C2168&osm_ids=1426&oxm_ids=2593&ofm_ids=1017&instance_id=0&object_id=21628&BrowserTZ=America%2FLos_Angeles&app_name=RoboScout&mode=CSV"
Debug.Print URL
H.SetAutoLogonPolicy 0
H.SetTimeouts 0, 0, 0, 0
H.Open "GET", URL, False
H.SetClientCertificate "CURRENT_USER\MY\" & Environ("USERNAME")
H.setRequestHeader "Cookie", VBAMidway_v1()
H.send
H.WaitForResponse
Debug.Print H.Status
Debug.Print H.responseText
dataobj.SetText H.responseText
dataobj.PutInClipboard
With Sheets("OOWA")
.Activate
.Cells.Clear
.Cells(1, 1).Select
.PasteSpecial Format:="Text", link:=False, DisplayAsIcon:=False, NoHTMLFormatting:=True
.Columns("A:A").TextToColumns DataType:=xlDelimited, ConsecutiveDelimiter:=False, Comma:=True, Space:=False
End With
End Sub
Sub pullKiva_Scout(sDate, eDate, sTime, eTime)
Dim H As New WinHttp.WinHttpRequest
Dim dataobj As New MSForms.DataObject
Dim URL As String
Dim html As New HTMLDocument
Dim htmlMetricTotals As HTMLHtmlElement
Dim htmlTable As HTMLHtmlElement
Dim htmlTBody As HTMLHtmlElement
Dim htmlTR As HTMLHtmlElement
Dim i As Integer
On Error Resume Next
i = 2
'sDate = ConvertFromLocalTimezoneToUTC(sDate)
'eDate = ConvertFromLocalTimezoneToUTC(eDate)
'sDate = toUnix(sDate)
'eDate = toUnix(eDate)
URL = "https://kivascout.amazon.com/view_plot_data/?sites=(LGB3" _
& ")&current_day=false&startDateTime=" & Format(sDate, "yyyy-mm-dd") _
& Format(sTime, "+hh%3A") _
& Format(sTime, "nn%3A") _
& "00&endDateTime=" _
& Format(eDate, "yyyy-mm-dd") _
& Format(eTime, "+hh%3A") _
& Format(eTime, "nn%3A") _
& "00&mom_ids=394%2C362%2C379%2C426&osm_ids=&oxm_ids=444&ofm_ids=&viz=nvd3Table&instance_id=1927&object_id=19851&BrowserTZ=America%2FLos_Angeles&app_name=RoboScout&mode=CSV"
Debug.Print URL
H.SetAutoLogonPolicy 0
H.SetTimeouts 0, 0, 0, 0
H.Open "GET", URL, False
H.SetClientCertificate "CURRENT_USER\MY\" & Environ("USERNAME")
H.setRequestHeader "Cookie", VBAMidway_v1()
H.send
H.WaitForResponse
Debug.Print H.Status
Debug.Print H.responseText
dataobj.SetText H.responseText
dataobj.PutInClipboard
With Sheets("Kiva_Scout")
.Activate
.Cells.Clear
.Cells(1, 1).Select
.PasteSpecial Format:="Text", link:=False, DisplayAsIcon:=False, NoHTMLFormatting:=True
.Columns("A:A").TextToColumns DataType:=xlDelimited, ConsecutiveDelimiter:=False, Comma:=True, Space:=False
End With
End Sub
Im kinda stuck here I need my code to be able to check to see if the value for sheet2.[B5] is greater than the value for Sheet2.[B6] then it will use the value for Sheet2.[B8] instead of the value in Sheet2.[B2] but only for the following calls(OOWA, Pod_gaps, Kiva_scout). sorry if I didn't write this well I'm new to VBA

Excel Macro (Separate Data)

I have an excel macro that can separate and save files per column. My problem is that I cannot make it work with large number of rows (60,000).
What should I change in my VBA code below to make it work?
Dim MyFile, NewFile As Variant
Dim sort_data As String
Dim last_row, tfiles, start_row, ktr As Integer
'Capture errors
On Error GoTo ErrorHandler
'Check for complete data
If (Separate.file_open.Value = False And Separate.Filename _
= "") Or Separate.first = "" Or Separate.last = "" Or _
Separate.sort = "" Or Separate.left_column = "" Or _
Separate.right = "" Then
MsgBox "Insufficient data.", 16, "Warning!"
Exit Sub
End If
'Turn application alerts off
Application.DisplayAlerts = False
'Open filename if necessary
If Separate.file_open.Value = False Then
Workbooks.Open Separate.Filename
End If
'Get current workbook name
MyFile = left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) _
- 4)
'Get last row of data
For last_row = Separate.last + 1 To 1048576
If Range(Separate.sort & last_row).Value = "" Then
Exit For
End If
Next last_row
'Sort data
Range(Separate.left_column & Separate.last, Separate.right & last_row).Select
Selection.sort Key1:=Range(Separate.sort & Separate.last + 1), Order1:=xlAscending, Header:=True, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
The problem is due to:
Dim last_row, tfiles, start_row, ktr As Integer
Integer mentioned in the script having a max number 32,767. You can use Long instead of Integer.
Dim last_row, tfiles, start_row, ktr As Long

How to download data from Yahoo finance limited to 100 rows

So I'm doing this project where I have to download historical stock data from yahoo finance. Got this code. It's working fine, BUT it only downloads max 100 rows. I tried to scan the web for answers or a different code (this one is just recorded macro from excel) but I saw a few tutorials on YouTube that use his solution and it's just fine.
.. I don't understand it then
Sub Makro6()
' Dowload stock prices from Yahoo Finance based on input
Dim ws As Worksheet
Set ws = Sheets("Data")
'clear previous queries
For Each qr In ThisWorkbook.Queries
qr.Delete
Next qr
'clear Data sheet
ws.Select
Cells.Clear
'clear graphs
'ws.ChartObjects.Delete
'stock = Sheets("Main").Range("A2")
StartDate = toUnix(Sheets("Main").Range("A4"))
EndDate = toUnix(Sheets("Main").Range("A6"))
Application.CutCopyMode = False
ActiveWorkbook.Queries.Add Name:="Table 2 (3)", Formula:= _
"let" & Chr(13) & "" & Chr(10) & " Zdroj = Web.Page(Web.Contents(""https://finance.yahoo.com/quote/" & stock & "/history?period1=" & StartDate & "&period2=" & EndDate & "&interval=1d&filter=history&frequency=1d""))," & Chr(13) & "" & Chr(10) & " Data2 = Zdroj{2}[Data]," & Chr(13) & "" & Chr(10) & " #""Změněný typ"" = Table.TransformColumnTypes(Data2,{{""Date"", type date}, {""Open"", type text}, {""High"", type text}, {""Low"", type text}, {""Close*"", type tex" & _
"t}, {""Adj Close**"", type text}, {""Volume"", type text}})" & Chr(13) & "" & Chr(10) & "in" & Chr(13) & "" & Chr(10) & " #""Změněný typ"""
With ActiveSheet.ListObjects.Add(SourceType:=0, Source:= _
"OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=""Table 2 (3)"";Extended Properties=""""" _
, Destination:=Range("$A$1")).QueryTable
.CommandType = xlCmdSql
.CommandText = Array("SELECT * FROM [Table 2 (3)]")
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
.ListObject.DisplayName = "Table_2_3"
.Refresh BackgroundQuery:=False
End With
Sheets("Data").Select
'' Sort data by date from oldest to newest
ws.ListObjects("Table_2_3").Sort.SortFields. _
Clear
ws.ListObjects("Table_2_3").Sort.SortFields. _
Add2 Key:=Range("A1:A99"), SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
With ws.ListObjects("Table_2_3").Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Call DeleteDividends
Call Stochastics
End Sub
The code works for other websites. I tried to download Wikipedia page list of total 120 and it loaded data no problem.
The problem is the data from Yahoo finance website is a project requirement
If you check against the page you will discover only 100 results are initially present within the HTMLTable rows (tbody to be precise).
Enter the css selector [data-test="historical-prices"] tbody tr in the browser elements tab search box (F12 to open dev tools)and you will see this:
The rest of the rows are fed dynamically from a data store as you scroll down the page. Of course, your current method doesn't pick up on these. You can in fact issue an xhr request, regex out the appropriate javascript object housing all the rows, and parse with a json parser.
Here is roughly what you should currently see in response:
I use jsonconverter.bas as my json parser. Download raw code from here and add to standard module called jsonConverter . You then need to go VBE > Tools > References > Add reference to Microsoft Scripting Runtime.
#TimWilliams wrote a better unix conversion function here but I thought I would have a play at writing something different. I would advise you to stick with his as it is safer and faster.
VBA:
Option Explicit
Public Sub GetYahooData()
'< VBE > Tools > References > Microsoft Scripting Runtime
Dim json As Object, re As Object, s As String, xhr As Object, ws As Worksheet
Dim startDate As String, endDate As String, stock As String
Set ws = ThisWorkbook.Worksheets("Sheet1")
Set re = CreateObject("VBScript.RegExp")
Set xhr = CreateObject("MSXML2.XMLHTTP")
stock = "AAPL"
startDate = "1534809600"
endDate = "1566345600"
With xhr
.Open "GET", "https://finance.yahoo.com/quote/" & stock & "/history?period1=" & startDate & "&period2=" & endDate & "&interval=1d&filter=history&frequency=1d&_guc_consent_skip=" & GetCurrentUnix(Now()), False
.setRequestHeader "User-Agent", "Mozilla/5.0"
.send
s = .responseText
End With
s = GetJsonString(re, s)
If s = "No match" Then Exit Sub
Set json = JsonConverter.ParseJson(s)
WriteOutResults ws, json
End Sub
Public Sub WriteOutResults(ByVal ws As Worksheet, ByVal json As Object)
Dim item As Object, key As Variant, headers(), results(), r As Long, c As Long
headers = json.item(1).keys
ReDim results(1 To json.Count, 1 To UBound(headers) + 1)
For Each item In json
r = r + 1: c = 1
For Each key In item.keys
results(r, c) = item(key)
c = c + 1
Next
Next
With ws
.Cells(1, 1).Resize(1, UBound(headers) + 1) = headers
.Cells(2, 1).Resize(UBound(results, 1), UBound(results, 2)) = results
End With
End Sub
Public Function GetJsonString(ByVal re As Object, ByVal responseText As String) As String
With re
.Global = True
.MultiLine = True
.IgnoreCase = False
.Pattern = "HistoricalPriceStore"":{""prices"":(.*?\])" 'regex pattern to get json string
If .test(responseText) Then
GetJsonString = .Execute(responseText)(0).SubMatches(0)
Else
GetJsonString = "No match"
End If
End With
End Function
Public Function GetCurrentUnix(ByVal t As Double) As String
With CreateObject("htmlfile")
.parentWindow.execScript "function GetTimeStamp(t){return new Date(t).getTime() / 1000}", "jscript"
GetCurrentUnix = .parentWindow.GetTimeStamp(Now)
End With
End Function
Regex:
Python:
I initially wrote as python if of interest:
import requests, re, json
from bs4 import BeautifulSoup as bs
p = re.compile('HistoricalPriceStore":{"prices":(.*?\])')
r = requests.get('https://finance.yahoo.com/quote/AAPL/history?period1=1534809600&period2=1566345600&interval=1d&filter=history&frequency=1d&_guc_consent_skip=1566859607')
data = json.loads(p.findall(r.text)[0])

Import multiple CSV files from Internet into Excel

I use this code to retrieve historical stock prices for about 40 tickers. I found it here http://www.mathfinance.cn/download-multiple-stock-quotes-from-yahoo-finance
It downloads about half of the symbols before a Run-time Error '1004' pops up. "Unable to open http://table.finance.yahoo.com/table.csv?s=Tickersymbol&a=11&b=21&c=1998 The internet site reports that the item you requested cannot be found (HTTP/1.0 404)
Can I change the code so this error won't happen? The code is below
Sub Get_Yahoo_finance()
Dim Sh As Worksheet
Dim Rng As Range
Dim Cell As Range
Dim Ticker As String
Dim StartDate As Date
Dim EndDate As Date
Dim a, b, c, d, e, f
Dim StrURL As String
Set Sh = Worksheets("Input")
Set Rng = Sh.Range("A2:A" & Sh.Range("A65536").End(xlUp).Row)
For Each Cell In Rng
Ticker = Cell.Value
StartDate = Cell.Offset(0, 1).Value
EndDate = Cell.Offset(0, 2).Value
a = Format(Month(StartDate) - 1, "00") ' Month minus 1
b = Day(StartDate)
c = Year(StartDate)
d = Format(Month(EndDate) - 1, "00")
e = Day(EndDate)
f = Year(EndDate)
StrURL = "URL;http://table.finance.yahoo.com/table.csv?"
StrURL = StrURL & "s=" & Ticker & "&a=" & a & "&b=" & b
StrURL = StrURL & "&c=" & c & "&d=" & d & "&e=" & e
StrURL = StrURL & "&f=" & f & "&g=d&ignore=.csv"
If WorksheetExists(Ticker, ActiveWorkbook) Then
Application.DisplayAlerts = False
Sheets(Ticker).Select
ActiveWindow.SelectedSheets.Delete
ActiveWorkbook.Worksheets.Add.Name = Ticker
Else
ActiveWorkbook.Worksheets.Add.Name = Ticker
End If
With ActiveSheet.QueryTables.Add(Connection:=StrURL, Destination:=Range("A1"))
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlAllTables
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.Refresh BackgroundQuery:=False
End With
Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 4), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
Array(7, 1))
Range("A2").Select
Range(Selection, Selection.End(xlDown)).NumberFormat = "d-mmm-yy"
Columns("A:F").EntireColumn.AutoFit
Next Cell
End Sub
Function WorksheetExists(SheetName As String, _
Optional WhichBook As Workbook) As Boolean
'from Chip Pearson
Dim WB As Workbook
Set WB = IIf(WhichBook Is Nothing, ThisWorkbook, WhichBook)
On Error Resume Next
WorksheetExists = CBool(Len(WB.Worksheets(SheetName).Name) > 0)
End Function
EDIT: The code below fixes the issue you reported but runs out of memory very quickly. I have created another answer which I think is much better and robust
It looks like your query is not recognised by the server. You can add some error checks to continue if such an error is encountered.
Sub Get_Yahoo_finance()
Dim Sh As Worksheet
Dim Rng As Range
Dim Cell As Range
Dim Ticker As String
Dim StartDate As Date
Dim EndDate As Date
Dim a, b, c, d, e, f
Dim StrURL As String
Dim errorMsg As String
Set Sh = Worksheets("Input")
Set Rng = Sh.Range("A2:A" & Sh.Range("A65536").End(xlUp).Row)
For Each Cell In Rng
Ticker = Cell.Value
StartDate = Cell.Offset(0, 1).Value
EndDate = Cell.Offset(0, 2).Value
a = Format(Month(StartDate) - 1, "00") ' Month minus 1
b = Day(StartDate)
c = Year(StartDate)
d = Format(Month(EndDate) - 1, "00")
e = Day(EndDate)
f = Year(EndDate)
StrURL = "URL;http://table.finance.yahoo.com/table.csv?"
StrURL = StrURL & "s=" & Ticker & "&a=" & a & "&b=" & b
StrURL = StrURL & "&c=" & c & "&d=" & d & "&e=" & e
StrURL = StrURL & "&f=" & f & "&g=d&ignore=.csv"
If WorksheetExists(Ticker, ActiveWorkbook) Then
Application.DisplayAlerts = False
Sheets(Ticker).Select
ActiveWindow.SelectedSheets.Delete
ActiveWorkbook.Worksheets.Add.Name = Ticker
Else
ActiveWorkbook.Worksheets.Add.Name = Ticker
End If
With ActiveSheet.QueryTables.Add(Connection:=StrURL, Destination:=Range("A1"))
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlAllTables
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
On Error Resume Next
.Refresh BackgroundQuery:=False
errorMsg = IIf(Err.Number = 0, "", Err.Description)
On Error GoTo 0
End With
If errorMsg = "" Then
Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 4), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
Array(7, 1))
Range("A2").Select
Range(Selection, Selection.End(xlDown)).NumberFormat = "d-mmm-yy"
Columns("A:F").EntireColumn.AutoFit
Else
Range("A1") = errorMsg
End If
Next Cell
End Sub
Function WorksheetExists(SheetName As String, Optional WhichBook As Workbook) As Boolean '
'from Chip Pearson
Dim WB As Workbook
Set WB = IIf(WhichBook Is Nothing, ThisWorkbook, WhichBook)
On Error Resume Next
WorksheetExists = CBool(Len(WB.Worksheets(SheetName).Name) > 0)
End Function
You might want to delete the sheet instead of putting an error message in it or maybe send a MsgBox instead...
I can't get your method to work properly (I get out of memory errors after a few 100s of tickers).
So I got interested and dug a bit further. I propose another approach below which is more complex but yields better results (I uploaded the 500 stocks of the S&P in 3 minutes (about 3 seconds for the actual job in Excel, the rest is connection / download time). Just copy paste the whole code in a module and run the runBatch procedure.
Option Explicit
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMillisecond As Long)
Private Declare Function URLDownloadToCacheFile Lib "urlmon" _
Alias "URLDownloadToCacheFileA" (ByVal lpUnkcaller As Long, _
ByVal szURL As String, ByVal szFileName As String, _
ByVal dwBufLength As Long, ByVal dwReserved As Long, _
ByVal IBindStatusCallback As Long) As Long
Public Sub runBatch()
'Assumes there is a sheet called "Input" with 3 columns:
'Ticker, Start Date, End Date
'Actual data starts from Row 2
Dim tickerData As Variant
Dim ticker As String
Dim url As String
Dim i As Long
Dim yahooData As Variant
On Error GoTo error_handler
Application.ScreenUpdating = False
tickerData = Sheets("Input").UsedRange
For i = LBound(tickerData, 1) + 1 To UBound(tickerData, 1) 'skip first row
ticker = tickerData(i, 1)
url = getYahooUrl(ticker, tickerData(i, 2), tickerData(i, 3))
yahooData = getCsvContent(url)
If isArrayEmpty(yahooData) Then
MsgBox "No data found for " + ticker
Else
copyDataToSheet yahooData, ticker
End If
Next i
Application.ScreenUpdating = True
Exit Sub
error_handler:
MsgBox "Error found while reading ticker [" + ticker + "]: " + Err.Description
Application.ScreenUpdating = True
End Sub
Private Function getYahooUrl(ByVal ticker As String, ByVal startDate As Date, ByVal endDate As Date) As String
Dim a As String
Dim b As String
Dim c As String
Dim d As String
Dim e As String
Dim f As String
a = Format(Month(startDate) - 1, "00") ' Month minus 1
b = Day(startDate)
c = Year(startDate)
d = Format(Month(endDate) - 1, "00")
e = Day(endDate)
f = Year(endDate)
getYahooUrl = "http://table.finance.yahoo.com/table.csv?" & _
"s=" & ticker & "&" & _
"a=" & a & "&" & _
"b=" & b & "&" & _
"c=" & c & "&" & _
"d=" & d & "&" & _
"e=" & e & "&" & _
"f=" & f & "&" & _
"g=d&ignore=.csv"
End Function
Private Function getCsvContent(url As String) As Variant
Const RETRY_NUMS As Long = 3 'How m any times do we retry the download before giving up
Dim szFileName As String
Dim i As Long
For i = 1 To RETRY_NUMS
szFileName = Space$(300)
If URLDownloadToCacheFile(0, url, szFileName, Len(szFileName), 0, 0) = 0 Then
getCsvContent = getDataFromFile(Trim(szFileName), ",")
Kill Trim(szFileName) 'to make sure data is refreshed next time
Exit Function
End If
Sleep (500)
Next i
End Function
Private Sub copyDataToSheet(data As Variant, sheetName As String)
If Not WorksheetExists(sheetName) Then
Worksheets.Add.Name = sheetName
End If
With Sheets(sheetName)
.Cells.ClearContents
.Cells(1, 1).Resize(UBound(data, 1), UBound(data, 2)) = data
.Columns(1).NumberFormat = "d-mmm-yy"
.Columns("A:F").AutoFit
End With
End Sub
Private Function WorksheetExists(sheetName As String, Optional WhichBook As Workbook) As Boolean '
'from Chip Pearson
Dim WB As Workbook
Set WB = IIf(WhichBook Is Nothing, ThisWorkbook, WhichBook)
On Error Resume Next
WorksheetExists = CBool(Len(WB.Worksheets(sheetName).Name) > 0)
End Function
Private Function isArrayEmpty(parArray As Variant) As Boolean
'Returns false if not an array or dynamic array that has not been initialised (ReDim) or has been erased (Erase)
If IsArray(parArray) = False Then isArrayEmpty = True
On Error Resume Next
If UBound(parArray) < LBound(parArray) Then isArrayEmpty = True: Exit Function Else: isArrayEmpty = False
End Function
Private Function getDataFromFile(parFileName As String, parDelimiter As String, Optional parExcludeCharacter As String = "") As Variant 'V.20081021
'parFileName is supposed to be a delimited file (csv...)
'Returns an empty array if file is empty or can't be opened
'20081021: number of columns based on the line with the largest number of columns, not on the first line
' parExcludeCharacter: sometimes csv files have quotes around strings: "XXX" - if parExcludeCharacter = """" then removes the quotes
'20081022: Error Checks in place
Dim locLinesList() As Variant
Dim locData As Variant
Dim i As Long
Dim j As Long
Dim locNumRows As Long
Dim locNumCols As Long
Dim fso As Variant
Dim ts As Variant
Const REDIM_STEP = 10000
Set fso = CreateObject("Scripting.FileSystemObject")
On Error GoTo error_open_file
Set ts = fso.OpenTextFile(parFileName)
On Error GoTo unhandled_error
'Counts the number of lines and the largest number of columns
ReDim locLinesList(1 To 1) As Variant
i = 0
Do While Not ts.AtEndOfStream
If i Mod REDIM_STEP = 0 Then
ReDim Preserve locLinesList(1 To UBound(locLinesList, 1) + REDIM_STEP) As Variant
End If
locLinesList(i + 1) = Split(ts.ReadLine, parDelimiter)
j = UBound(locLinesList(i + 1), 1) 'number of columns
If locNumCols < j Then locNumCols = j
i = i + 1
Loop
ts.Close
locNumRows = i
If locNumRows = 0 Then Exit Function 'Empty file
ReDim locData(1 To locNumRows, 1 To locNumCols + 1) As Variant
'Copies the file into an array
If parExcludeCharacter <> "" Then
For i = 1 To locNumRows
For j = 0 To UBound(locLinesList(i), 1)
If Left(locLinesList(i)(j), 1) = parExcludeCharacter Then
If Right(locLinesList(i)(j), 1) = parExcludeCharacter Then
locLinesList(i)(j) = Mid(locLinesList(i)(j), 2, Len(locLinesList(i)(j)) - 2) 'If locTempArray = "", Mid returns ""
Else
locLinesList(i)(j) = Right(locLinesList(i)(j), Len(locLinesList(i)(j)) - 1)
End If
ElseIf Right(locLinesList(i)(j), 1) = parExcludeCharacter Then
locLinesList(i)(j) = Left(locLinesList(i)(j), Len(locLinesList(i)(j)) - 1)
End If
locData(i, j + 1) = locLinesList(i)(j)
Next j
Next i
Else
For i = 1 To locNumRows
For j = 0 To UBound(locLinesList(i), 1)
locData(i, j + 1) = locLinesList(i)(j)
Next j
Next i
End If
getDataFromFile = locData
Exit Function
error_open_file: 'returns empty variant
unhandled_error: 'returns empty variant
End Function
I ran it once and it failed. Put a breakpoint on the query line, loaded the yahoo address into my browser to make sure it was valid, then the script worked. I also made sure that there were no other worksheets in the project. Here's a screenshot of the VBA editor and where the breakpoint goes:
You can stick the variable into a watch window and then fool around with it to see what it does. If you come up with any applications for this I'd love to hear about them!
Attached is a "simpler" solution using the original code modified to retry retrieving the ticker data upto 3 times (waiting a few seconds between attempts) before finally admitting failure by messagebox. My 2 cents :-)
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMillisecond As Long)
Sub Get_Yahoo_finance_history()
Dim Sh As Worksheet
Dim Rng As Range
Dim Cell As Range
Dim Ticker As String
Dim StartDate As Date
Dim EndDate As Date
Dim a, b, c, d, e, f
Dim StrURL As String
Dim RetryCount As Integer
'turn calculation off
'Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Set Sh = Worksheets("Input")
Set Rng = Sh.Range("A2:A" & Sh.Range("A65536").End(xlUp).Row)
For Each Cell In Rng
Ticker = Cell.Value
StartDate = Cell.Offset(0, 1).Value
EndDate = Cell.Offset(0, 2).Value
a = Format(Month(StartDate) - 1, "00") ' Month minus 1
b = Day(StartDate)
c = Year(StartDate)
d = Format(Month(EndDate) - 1, "00")
e = Day(EndDate)
f = Year(EndDate)
StrURL = "URL;http://table.finance.yahoo.com/table.csv?"
StrURL = StrURL & "s=" & Ticker & "&a=" & a & "&b=" & b
StrURL = StrURL & "&c=" & c & "&d=" & d & "&e=" & e
StrURL = StrURL & "&f=" & f & "&g=d&ignore=.csv"
If WorksheetExists(Ticker, ActiveWorkbook) Then
Sheets(Ticker).Select
ActiveWindow.SelectedSheets.Delete
ActiveWorkbook.Worksheets.Add.Name = Ticker
Else
ActiveWorkbook.Worksheets.Add.Name = Ticker
End If
RetryCount = 0 Retry:
If RetryCount > 3 Then
Range("A1") = errorMsg
MsgBox "After 3 attempts: Could not retrieve data for " + Ticker
End
End If
RetryCount = RetryCount + 1
With ActiveSheet.QueryTables.Add(Connection:=StrURL, Destination:=Range("A1"))
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlAllTables
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
On Error Resume Next
.Refresh BackgroundQuery:=False
errorMsg = IIf(Err.Number = 0, "", Err.Description)
On Error GoTo 0
End With
If errorMsg = "" Then
Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 4), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
Array(7, 1))
Columns("A").EntireColumn.NumberFormat = "mm/dd/yyyy"
Columns("B:E").EntireColumn.NumberFormat = "$###,##0.00"
Columns("F").EntireColumn.NumberFormat = "###,##0"
Columns("B:E").EntireColumn.NumberFormat = "$###,##0.00"
Columns("A:F").EntireColumn.AutoFit
Else
Sleep (500)
Sheets(Ticker).Cells.ClearContents
GoTo Retry
End If
Next Cell
'turn calculation back on
'Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub
Function WorksheetExists(SheetName As String, _
Optional WhichBook As Workbook) As Boolean
'from Chip Pearson
Dim WB As Workbook
Set WB = IIf(WhichBook Is Nothing, ThisWorkbook, WhichBook)
On Error Resume Next
WorksheetExists = CBool(Len(WB.Worksheets(SheetName).Name) > 0)
End Function

Resources