Error trapping for historical stock data query

[artz]

Hi,

I've been using the code below in many stock analysis workbooks and generally, it works just fine. If I fat finger a wrong ticker and the sub doesn't run, I just click on "End" and go back and retype the ticker. I do the same when I lose my internet connection and get an error.

It would be nice though if these errors could be trapped with a "Ticker not found" message and a "No data connection" for the second. The code for the query is below:

Sub GetData()
'   thanks to Ron McEwan :^)

    Dim QuerySheet As Worksheet
    Dim DataSheet As Worksheet
    Dim EndDate As Date
    Dim StartDate As Date
    Dim Symbol As String
    Dim qurl As String
    Dim nQuery As Name
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual
    
    Set DataSheet = ActiveSheet
  
        StartDate = DataSheet.Range("B2").Value
        EndDate = DataSheet.Range("B3").Value
        Symbol = DataSheet.Range("B4").Value
        Range("C7").CurrentRegion.ClearContents
        
'construct the URL for the query
        
        qurl = "http://chart.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=" & Range("C3") & "&q=q&y=0&z=" & _
            Symbol & "&x=.csv"
        Range("b5") = qurl
                   
QueryQuote:
             With ActiveSheet.QueryTables.Add(Connection:="URL;" & qurl, Destination:=DataSheet.Range("C7"))
                .BackgroundQuery = True
                .TablesOnlyFromHTML = False
                .Refresh BackgroundQuery:=False
                .SaveData = True
            End With
            
            Range("C7").CurrentRegion.TextToColumns Destination:=Range("C7"), DataType:=xlDelimited, _
                TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
                Semicolon:=False, Comma:=True, Space:=False, other:=False
            
            Range(Range("C7"), Range("C7").End(xlDown)).NumberFormat = "mmm d/yy"
            Range(Range("D7"), Range("G7").End(xlDown)).NumberFormat = "0.00"
            Range(Range("H7"), Range("H7").End(xlDown)).NumberFormat = "0,000"
            Range(Range("I7"), Range("I7").End(xlDown)).NumberFormat = "0.00"


    With ThisWorkbook
        For Each nQuery In Names
            If IsNumeric(Right(nQuery.Name, 1)) Then
                nQuery.Delete
            End If
        Next nQuery
    End With
    
'turn calculation back on
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayAlerts = True
    Range("C7:I2000").Select
    Selection.Sort Key1:=Range("C8"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    Range("C1").Select
    Selection.ColumnWidth = 12

    Range("B4").Select

End Sub

As I suggested above, Mr.McEwan's code has been a trooper in many historical stock price queries posted online. Is there anyone here in the Forum who could take a stab with some VBA code to trap these errors? I am sure that users of Mr.McEwan's query code would be highly grateful. (As would I )

Thanks,

Art

 

[Jerry Sullivan]

Hi Art, I've added error handling in the code below along with making the code more consistent in referencing the worksheet directly.

Sub GetData()
' based on code by Ron McEwan

 Dim DataSheet As Worksheet
 Dim EndDate As Date
 Dim StartDate As Date
 Dim Symbol As String
 Dim qurl As String
 Dim sErrMsg As String
 Dim nQuery As Name

 On Error GoTo ErrProc
  
 Application.ScreenUpdating = False
 Application.DisplayAlerts = False
 Application.Calculation = xlCalculationManual
    
 Set DataSheet = ActiveSheet
 
 With DataSheet
   StartDate = .Range("B2").Value
   EndDate = .Range("B3").Value
   Symbol = .Range("B4").Value
   .Range("C7").CurrentRegion.ClearContents
 End With
 
'construct the URL for the query
 qurl = "http://chart.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=" & Range("C3") & "&q=q&y=0&z=" & _
    Symbol & "&x=.csv"
 
 With DataSheet
   .Range("b5") = qurl
   With .QueryTables.Add(Connection:="URL;" & qurl, Destination:=.Range("C7"))
      .BackgroundQuery = True
      .TablesOnlyFromHTML = False
      .Refresh BackgroundQuery:=False
      .SaveData = True
   End With

   .Range("C7").CurrentRegion.TextToColumns _
      Destination:=.Range("C7"), DataType:=xlDelimited, _
      TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
      Semicolon:=False, Comma:=True, Space:=False, other:=False

   Range(.Range("C7"), .Range("C7").End(xlDown)).NumberFormat = "mmm d/yy"
   Range(.Range("D7"), .Range("G7").End(xlDown)).NumberFormat = "0.00"
   Range(.Range("H7"), .Range("H7").End(xlDown)).NumberFormat = "0,000"
   Range(.Range("I7"), .Range("I7").End(xlDown)).NumberFormat = "0.00"

   .Range("C7:I2000").Sort Key1:=.Range("C8"), Order1:=xlAscending, Header:=xlGuess, _
      OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
   .Range("C1").EntireColumn.ColumnWidth = 12

   .Range("B4").Select
 End With

 With ThisWorkbook
   For Each nQuery In Names
      If IsNumeric(Right(nQuery.Name, 1)) Then
         nQuery.Delete
      End If
   Next nQuery
 End With

ExitProc:
 On Error Resume Next
    
'turn calculation back on
 Application.Calculation = xlCalculationAutomatic
 Application.DisplayAlerts = True
 Application.ScreenUpdating = True
 If Len(sErrMsg) Then MsgBox sErrMsg
 Exit Sub

ErrProc:
 sErrMsg = Err.Number & ": " & Err.Description
 Resume ExitProc
End Sub

 

[artz]

Hi Jerry,

Thanks for taking a stab at this; I really appreciate it. I probably should have posted all the Module code. Here's why. The errors are definitely trapped but now the screen updating is a little wonky. Before using your code, if I clicked the download button, the charts were "neatly" updated. Now the charts kind of flash and it doesn't look clean.

Below is the Module code:

Sub GetTwo()
'clear data

    Range("K8:M300").Select
    Selection.ClearContents
    Range("P8:R300").Select
    Selection.ClearContents
    
' get first stock
    Range("B4") = Range("M6")
    GetData
    Range("E8:G1000").Select
    Selection.Copy
    Range("K8").Select
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    UpdateScale1
    
' get second stock
    Range("B4") = Range("R6")
    GetData
    Range("E8:G1000").Select
    Selection.Copy
    Range("P8").Select
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
        Range("AA8:GG1000").Select
    Selection.Copy
    UpdateScale2

Range("A1").Select
End Sub




Sub GetData()
' based on code by Ron McEwan

 Dim DataSheet As Worksheet
 Dim EndDate As Date
 Dim StartDate As Date
 Dim Symbol As String
 Dim qurl As String
 Dim sErrMsg As String
 Dim nQuery As Name

 On Error GoTo ErrProc
  
 Application.ScreenUpdating = False
 Application.DisplayAlerts = False
 Application.Calculation = xlCalculationManual
    
 Set DataSheet = ActiveSheet
 
 With DataSheet
   StartDate = .Range("B2").Value
   EndDate = .Range("B3").Value
   Symbol = .Range("B4").Value
   .Range("C7").CurrentRegion.ClearContents
 End With
 
'construct the URL for the query
 qurl = "http://chart.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=" & Range("C3") & "&q=q&y=0&z=" & _
    Symbol & "&x=.csv"
 
 With DataSheet
   .Range("b5") = qurl
   With .QueryTables.Add(Connection:="URL;" & qurl, Destination:=.Range("C7"))
      .BackgroundQuery = True
      .TablesOnlyFromHTML = False
      .Refresh BackgroundQuery:=False
      .SaveData = True
   End With

   .Range("C7").CurrentRegion.TextToColumns _
      Destination:=.Range("C7"), DataType:=xlDelimited, _
      TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
      Semicolon:=False, Comma:=True, Space:=False, other:=False

   Range(.Range("C7"), .Range("C7").End(xlDown)).NumberFormat = "mmm d/yy"
   Range(.Range("D7"), .Range("G7").End(xlDown)).NumberFormat = "0.00"
   Range(.Range("H7"), .Range("H7").End(xlDown)).NumberFormat = "0,000"
   Range(.Range("I7"), .Range("I7").End(xlDown)).NumberFormat = "0.00"

   .Range("C7:I2000").Sort Key1:=.Range("C8"), Order1:=xlAscending, Header:=xlGuess, _
      OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
   .Range("C1").EntireColumn.ColumnWidth = 12

   .Range("B4").Select
 End With

 With ThisWorkbook
   For Each nQuery In Names
      If IsNumeric(Right(nQuery.Name, 1)) Then
         nQuery.Delete
      End If
   Next nQuery
 End With

ExitProc:
 On Error Resume Next
    
'turn calculation back on
 Application.Calculation = xlCalculationAutomatic
 Application.DisplayAlerts = True
 Application.ScreenUpdating = True
 If Len(sErrMsg) Then MsgBox sErrMsg
 Exit Sub

ErrProc:
 sErrMsg = Err.Number & ": " & Err.Description
 Resume ExitProc
End Sub
Sub UpdateScale1()
Dim ChartVar As chart
Dim lMax As Long, lMin As Long

On Error GoTo ScalingProblem
    'Assigns the values in the Min and Max ranges to variables.
    With Sheet1
        lMax = .Range("One_Max").Value
        lMin = .Range("One_Min").Value
        'Creates chart object.
        Set ChartVar = .ChartObjects("Chart 32").chart
     
            
               With ChartVar.Axes(xlValue, xlPrimary)  'Adjusts the price axis
                   .MinimumScale = lMin
                   .MaximumScale = lMax
               End With
            
    End With
Exit Sub

ScalingProblem:
RetrievalProblem:
    MsgBox "Unable to update chart scale.", vbCritical + vbOKOnly, "Scaling Error"
End Sub
Sub UpdateScale2()
Dim ChartVar As chart
Dim lMax As Long, lMin As Long

On Error GoTo ScalingProblem
    'Assigns the values in the Min and Max ranges to variables.
    With Sheet1
        lMax = .Range("Two_Max").Value
        lMin = .Range("Two_Min").Value
        'Creates chart object.
        Set ChartVar = .ChartObjects("Chart 48").chart
     
            
               With ChartVar.Axes(xlValue, xlPrimary)  'Adjusts the price axis
                   .MinimumScale = lMin
                   .MaximumScale = lMax
               End With
            
    End With
Exit Sub

ScalingProblem:
RetrievalProblem:
    MsgBox "Unable to update chart scale.", vbCritical + vbOKOnly, "Scaling Error"
End Sub

Could you take a look and see if you can fix this?

Thanks so much,

Art

 

[Jerry Sullivan]

Art,

You can move the Application setting and error handling from the front and end of GetData over to the front and end of GetTwo.

 

[artz]

Hi Jerry,

Thanks for your response and comments. I don't quite follow what you are suggesting to do. i read what you are saying, but don't exactly know what to move where.

Art

 

[Jerry Sullivan]

Hi Art,

Here's what I was suggesting for those two subs. Note that there's no need to Select objects before copying them. It's more efficient and clearer coding to directly reference the objects without selecting them.

Sub GetTwo()
 Dim sErrMsg As String
 
 On Error GoTo ErrProc
  
 Application.ScreenUpdating = False
 Application.DisplayAlerts = False
 Application.Calculation = xlCalculationManual

'clear data
 Range("K8:M300").ClearContents
 Range("P8:R300").ClearContents
    
' get first stock
 Range("B4") = Range("M6")
 GetData
 Range("E8:G1000").Copy
 Range("K8").PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=False
 UpdateScale1
    
' get second stock
 Range("B4") = Range("R6")
 GetData
 Range("E8:G1000").Copy
 Range("P8").PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
        
'---this doesn't appear to be used/needed
[COLOR="#FF0000"] Range("AA8:GG1000").Select
 Selection.Copy[/COLOR]
    
 UpdateScale2

 Range("A1").Select

ExitProc:
 On Error Resume Next
    
'turn calculation back on
 Application.Calculation = xlCalculationAutomatic
 Application.DisplayAlerts = True
 Application.ScreenUpdating = True
 If Len(sErrMsg) Then MsgBox sErrMsg
 Exit Sub

ErrProc:
 sErrMsg = Err.Number & ": " & Err.Description
 Resume ExitProc

End Sub


Sub GetData()
' based on code by Ron McEwan

 Dim DataSheet As Worksheet
 Dim EndDate As Date
 Dim StartDate As Date
 Dim Symbol As String
 Dim qurl As String
 Dim nQuery As Name

    
 Set DataSheet = ActiveSheet
 
 With DataSheet
   StartDate = .Range("B2").Value
   EndDate = .Range("B3").Value
   Symbol = .Range("B4").Value
   .Range("C7").CurrentRegion.ClearContents
 End With
 
'construct the URL for the query
 qurl = "http://chart.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=" & Range("C3") & "&q=q&y=0&z=" & _
    Symbol & "&x=.csv"
 
 With DataSheet
   .Range("b5") = qurl
   With .QueryTables.Add(Connection:="URL;" & qurl, Destination:=.Range("C7"))
      .BackgroundQuery = True
      .TablesOnlyFromHTML = False
      .Refresh BackgroundQuery:=False
      .SaveData = True
   End With

   .Range("C7").CurrentRegion.TextToColumns _
      Destination:=.Range("C7"), DataType:=xlDelimited, _
      TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
      Semicolon:=False, Comma:=True, Space:=False, other:=False

   Range(.Range("C7"), .Range("C7").End(xlDown)).NumberFormat = "mmm d/yy"
   Range(.Range("D7"), .Range("G7").End(xlDown)).NumberFormat = "0.00"
   Range(.Range("H7"), .Range("H7").End(xlDown)).NumberFormat = "0,000"
   Range(.Range("I7"), .Range("I7").End(xlDown)).NumberFormat = "0.00"

   .Range("C7:I2000").Sort Key1:=.Range("C8"), Order1:=xlAscending, Header:=xlGuess, _
      OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
   .Range("C1").EntireColumn.ColumnWidth = 12

   .Range("B4").Select
 End With

 With ThisWorkbook
   For Each nQuery In Names
      If IsNumeric(Right(nQuery.Name, 1)) Then
         nQuery.Delete
      End If
   Next nQuery
 End With

End Sub

 

[artz]

Hi Jerry,

Thanks for taking a second look. It's funny, I didn't receive a notice from the Forum that you had reposted. Hmmm.... So I just got your new code and stuffed into in my workbook. The first time that I clicked the Download button, the screen looked almost static; barely a perception that the ticker data had been downloaded and the charts updated.

So I thought, alright, this is great; let's start using the workbook. Unfortunately when I changed both tickers and clicked Download, I got no data plotted in the charts at all; and no error messages. Like I said in my previous post, that first code worked to trap errors, but the screen updating kind of jumped around.

Any thoughts? Too bad we don't have a way to share files; I'd just send it t you so you can see what I am seeing.

Thanks,

Art