VBA Фондовый поиск информации в Excel
Прежде всего, я должен признать, что я не очень хорош в VBA. Я пытался адаптировать код с этого и этого сайта, чтобы загрузить информацию, которая мне нужна, в списке заданных тикеров. У меня есть список тикеров в столбце А листа "данные", и я хочу, чтобы загруженная информация (имя, обмен, заявка, запрос и т. Д.) Была в столбцах справа, начиная с столбца с. Я хочу запустить макрос (и, таким образом, обновить все значения) одним нажатием на кнопку. Я попытался соответствующим образом адаптировать код, но продолжаю сталкиваться с ошибками, которые не могу отладить. Можете ли вы эксперты помочь мне получить правильный код?
Большое спасибо заранее!
ошибка
Sub DownloadStockQuotes(ByVal stockTicker As String, ByVal DestinationCell As String)
Dim qurl As String
Dim StartMonth, StartDay, StartYear, EndMonth, EndDay, EndYear As String
Dim C As WorkbookConnection
StartMonth = Format(Month(StartDate) - 1, "00")
StartDay = Format(Day(StartDate), "00")
StartYear = Format(Year(StartDate), "00")
EndMonth = Format(Month(EndDate) - 1, "00")
EndDay = Format(Day(EndDate), "00")
EndYear = Format(Year(EndDate), "00")
qurl = "URL;http://finance.yahoo.com/d/quotes.csv?s=" + stockTicker + "&f=nxj1b4abc1p2"
On Error GoTo ErrorHandler:
With ActiveSheet.QueryTables.Add(Connection:=qurl, Destination:=Range(DestinationCell))
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
' .PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
' .RefreshPeriod = 0
' .WebSelectionType = xlSpecifiedTables
' .WebFormatting = xlWebFormattingNone
' .WebTables = "20"
' .WebPreFormattedTextToColumns = True
' .WebConsecutiveDelimitersAsOne = True
' .WebSingleBlockTextImport = False
' .WebDisableDateRecognition = False
' .WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
ErrorHandler:
End Sub
Sub DownloadData()
Dim frequency As String
Dim numRows As Integer
Dim lastRow As Integer
Dim lastErrorRow As Integer
Dim lastSuccessRow As Integer
Dim stockTicker As String
Application.ScreenUpdating = False
lastRow = Worksheets("Kursabruf").Cells(Rows.Count, "a").End(xlUp).Row
'Loop through all tickers
For ticker = 2 To lastRow
stockTicker = Worksheets("Kursabruf").Range("$a$" & ticker)
If stockTicker = "" Then
GoTo NextIteration
End If
Call DownloadStockQuotes(stockTicker, "$c$2")
Worksheets("Kursabruf").Columns("c:c").TextToColumns Destination:=Range("c2"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
DecimalSeparator:=".", ThousandsSeparator:=" ", _
Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1))
Sheets(stockTicker).Columns("A:G").ColumnWidth = 10
lastRow = Sheets(stockTicker).UsedRange.Row - 2 + Sheets(stockTicker).UsedRange.Rows.Count
GoTo NextIteration
'Delete final blank row otherwise will get ,,,, at bottom of CSV
Sheets("Kursabruf").Rows(lastRow + 1 & ":" & Sheets("Kursabruf").Rows.Count).Delete
NextIteration:
Next ticker
Application.DisplayAlerts = False
ErrorHandler:
Worksheets("Parameters").Select
For Each C In ThisWorkbook.Connections
C.Delete
Next
End Sub