andrewso (andrewsoa) wrote,
andrewso
andrewsoa

Загрузчик данных с сайта Yahoo, макрос Excel VBA

        В продолжение темы (1), (2), (3). Модификация макросов по адресу (3) но для загрузки данных с сайта (finance.yahoo.com).
Принцип действия полностью аналогичен описанному в (3). Изменения внесены только в части URL-запроса и имени создаваемой папки для загружаемых файлов.
        Следует заметить что сервер finance.yahoo.com отдаёт данные сортированные "наоборот" - от новых данных к старым. Макрос осуществляющий обратную сортировку у меня есть, но при работе он загружает данные на лист. Что явно избыточно. Потом, может, напишу код осуществляющий сортировку в памяти. ))

[Spoiler (click to open)].
'Совместимость 32- и 64-разрядных версий Office 2010'
'http://msdn.microsoft.com/ru-ru/library/ee691831.aspx
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
#If VBA7 Then
'макрос закачки файлов из интернета.
Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, _
ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long

Public Function DownloadFile(URL As String, LocalFilename As String) As Boolean
Dim lngRetVal As Long
lngRetVal = URLDownloadToFile(0, URL, LocalFilename, 0, 0)
If lngRetVal = 0 Then DownloadFile = True

End Function
#Else
'макрос закачки файлов из интернета.
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, _
ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long

Public Function DownloadFile(URL As String, LocalFilename As String) As Boolean
Dim lngRetVal As Long
lngRetVal = URLDownloadToFile(0, URL, LocalFilename, 0, 0)
If lngRetVal = 0 Then DownloadFile = True
End Function
#End If



Sub YahooUpload() 'макрос закачки данных с сайта Yahoo в .csv файл
'считывание имён тикеров из массива заданного в теле макроса
'http://finance.yahoo.com/q/cp?s=^IXIC+Components
Dim FileFolder As String 'имя папки для закачиваемых данных
Dim Filename As String 'имя файла для закачиваемых данных
Dim dateStart As Date 'начало временного диапазона закачиваемых данных
Dim dateEnd As Date 'конец временного диапазона закачиваемых данных
Dim ticker As String 'код данных (тикера)
Dim spisokArray() As String 'массив, список закачиваемых кодов (тикеров)
Dim RowArray As Integer 'количество строк в массиве записанных кодов данных (тикеров)
Dim i As Integer 'счётчик циклов
Dim t As Variant 'системное время при запуске макроса
Dim a, b, c, d, e, f As Variant 'элементы заданных дат
Dim iDelay As Integer 'принудительная задержка между загрузкой тикеров, сек.

'включаем программную обработку ошибок с автоматическом передачей управления на следующий оператор
'On Error Resume Next

Application.Calculation = xlManual 'выключаем автоматический пересчёт в книге
Application.ScreenUpdating = False 'отключаем обновление экрана

t = Timer 'системное время при запуске макроса

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'НАСТРОЙКИ РАБОТЫ МАКРОСА:
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
dateStart = Now - 365 'значение даты начала требуемого диапазона данных, по умолчанию: -год от текущей даты;
'dateStart = "01.01.2012" 'значение даты начала требуемого диапазона данных
'MsgBox "Начальная дата данных: " & dateStart 'сообщение, для отладки
iDelay = 0 'принудительная задержка между загрузкой тикеров, сек.

ReDim spisokArray(100, 0) 'задание размерности массива (строк, столбцов).
'ВАРИАНТ 1 задания закачиваемых тикеров
''''''''''''''''''''''''''''''''''''''''''''''''''''
'Если требуется закачивать число тикеров больше 101 -
'просто поменять здесь, размерности массива (>101), а затем добавить и заполнить строки по порядку ниже:
'заполнение массива кодами загружаемых тикеров
spisokArray(0, 0) = "^XAX" 'код тикера "AMEX COMPOSITE INDEX (^XAX)-NYSE" http://finance.yahoo.com/q?s=^XAX
spisokArray(1, 0) = "^BVSP" 'код тикера "IBOVESPA - (^BVSP)-Sao Paolo " http://finance.yahoo.com/q?s=%22^BVSP%22&ql=1
spisokArray(2, 0) = "^BSESN" 'код тикера "S&P BSE SENSEX (^BSESN)-BSE " http://finance.yahoo.com/q?s=%22^BSESN%22&ql=1
'spisokArray(3, 0) = "" 'код тикера ""
'spisokArray(4, 0) = "" 'код тикера ""
'spisokArray(5, 0) = "" 'код тикера ""
'spisokArray(6, 0) = "" 'код тикера ""
'spisokArray(7, 0) = "" 'код тикера ""
'spisokArray(8, 0) = "" 'код тикера ..
' ...

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'авт. настройки
dateEnd = Now 'значение даты конца требуемого диапазона данных, по умолчанию текущая дата
a = Format(Month(dateStart) - 1, "00") ' месяц, -1
b = Day(dateStart) 'номер дня начала периода закачки
c = Year(dateStart) 'номер года начала периода закачки
d = Format(Month(dateEnd) - 1, "00") 'месяц
e = Day(dateEnd) 'номер дня конца периода закачки
f = Year(dateEnd) 'номер года конца периода закачки
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'конец настроек
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'присваиваем путь для закачиваемых данных, в ту же папку, где и файл книги макроса
FileFolder = Application.ThisWorkbook.Path & "\YahooData" 'имя папки для закачиваемых данных
'
If Dir(FileFolder, vbDirectory) = "" Then 'проверяем существования папки "FileFolder"
MsgBox "Будет создана папка: " & FileFolder 'сообщение
MkDir (FileFolder) 'создаём папку "имя папки"
End If
'
RowArray = UBound(spisokArray, 1) 'количество строк в массиве spisokArray()

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'все тикеры закачиваются в отдельные файлы
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
For i = 0 To RowArray 'цикл с первой строки массива и до конца по заданным кодам
'принудительная задержка, при слишком быстрой загрузке, видимо, сервер
'Finam прерывает соединение - Excel может зависнуть
If (i Mod 5) = 0 And i > 0 Then 'формула возвращения остатка, т.о. после каждого
'5-го загруженного тикера задержка iDelay*3 сек.
Application.Wait Now + TimeSerial(0, 0, iDelay * 3) 'задержка iDelay*3 сек.
DoEvents 'передача ресурсов системы другим процессам
Else: 'иначе, после каждого загруженного тикера задержка iDelay сек.
Application.Wait Now + TimeSerial(0, 0, iDelay) 'задержка iDelay сек.
DoEvents 'передача ресурсов системы другим процессам
End If

ticker = spisokArray(i, 0) 'считывание имени тикера
If ticker <> "" Then 'если не пустая строка в массиве кодов тикеров
Filename = FileFolder & "\" & ticker & ".csv" 'путь, имя отдельного файла для тикера
If Dir(Filename) <> "" Then Kill Filename 'удаление старого файла, с проверкой его существования
'Загрузка данных отдельными файлами
DownloadFile "http://table.finance.yahoo.com/table.csv?" & "s=" & ticker & "&a=" & a & "&b=" & b _
& StrURL & "&c=" & c & "&d=" & d & "&e=" & e & StrURL & "&f=" & f & "&g=d&ignore=.csv", Filename
End If
Next i

Erase spisokArray() 'удаление массива spisokArray() из памяти

Application.Calculation = xlAutomatic 'включаем автоматический пересчёт в книге
Application.ScreenUpdating = True 'включаем обновление экрана

'сообщение
MsgBox "Готово!" & vbNewLine _
& "Путь к загруженным данным: " & FileFolder & vbNewLine _
& "Время выполнения макроса: " & (Timer - t) * 1000 & " msec", 65, "Макрос: YahooUpload"
End Sub



Sub YahooUpload_2() 'макрос закачки данных с сайта Yahoo в .csv файл
'считывание имён тикеров из диапазона на листе книги
'http://finance.yahoo.com/q/cp?s=^IXIC+Components
Dim FileFolder As String 'имя папки для закачиваемых данных
Dim Filename As String 'имя файла для закачиваемых данных
Dim dateStart As Date 'начало временного диапазона закачиваемых данных
Dim dateEnd As Date 'конец временного диапазона закачиваемых данных
Dim ticker As String 'код данных (тикера)
Dim i As Integer 'счётчик циклов
Dim t As Variant 'системное время при запуске макроса
Dim a, b, c, d, e, f As Variant 'элементы заданных дат
Dim iDelay As Integer 'принудительная задержка между загрузкой тикеров, сек.
Dim dataSheet As Excel.Worksheet 'страница задания настроек в книге, в ячейках листа
Dim RowStart As Long 'начальная строка задания тикеров на листе в книге
Dim RowEnd As Long 'конечная заполненная строка задания тикеров на листе в книге
Dim iClm As Integer 'столбец задания тикеров на листе в книге

'включаем программную обработку ошибок с автоматическом передачей управления на следующий оператор
'On Error Resume Next

Application.Calculation = xlManual 'выключаем автоматический пересчёт в книге
Application.ScreenUpdating = False 'отключаем обновление экрана

t = Timer 'системное время при запуске макроса

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'НАСТРОЙКИ РАБОТЫ МАКРОСА:
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
dateStart = Now - 365 'значение даты начала требуемого диапазона данных, по умолчанию: -год от текущей даты;
'dateStart = "01.01.2012" 'значение даты начала требуемого диапазона данных
'MsgBox "Начальная дата данных: " & dateStart 'сообщение, для отладки
Set dataSheet = Application.ThisWorkbook.Worksheets("Settings") 'имя страницы задания имён тикеров в книге, в ячейках листа
RowStart = 6 'начальная строка задания тикеров на листе в книге
iClm = 2 'столбец задания тикеров на листе в книге
iDelay = 0 'принудительная задержка между загрузкой тикеров, сек.

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'авт. настройки
dateEnd = Now 'значение даты конца требуемого диапазона данных, по умолчанию текущая дата
a = Format(Month(dateStart) - 1, "00") ' месяц, -1
b = Day(dateStart) 'номер дня начала периода закачки
c = Year(dateStart) 'номер года начала периода закачки
d = Format(Month(dateEnd) - 1, "00") 'месяц
e = Day(dateEnd) 'номер дня конца периода закачки
f = Year(dateEnd) 'номер года конца периода закачки
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'конец настроек
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'присваиваем путь для закачиваемых данных, в ту же папку, где и файл книги макроса
FileFolder = Application.ThisWorkbook.Path & "\YahooData" 'имя папки для закачиваемых данных
'
If Dir(FileFolder, vbDirectory) = "" Then 'проверяем существования папки "FileFolder"
MsgBox "Будет создана папка: " & FileFolder 'сообщение
MkDir (FileFolder) 'создаём папку "имя папки"
End If '

'ВАРИАНТ 2 считывание имён закачиваемых тикеров с листа
''''''''''''''''''''''''''''''''''''''''''''''''''''
dataSheet.Select 'переход на страницу задания тикеров
'определение номера последней заполненной строки данных в столбце iClm листа dataSheet
RowEnd = dataSheet.Columns(iClm).Find(What:="*", _
LookIn:=xlValues, SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'все тикеры закачиваются в отдельные файлы
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
For i = RowStart To RowEnd 'цикл с первой строки диапазона тикеров и до конца по заданным кодам
'принудительная задержка, при слишком быстрой загрузке, видимо, сервер
'Finam прерывает соединение - Excel может зависнуть
If (i Mod 5) = 0 And i > 0 Then 'формула возвращения остатка, т.о. после каждого
'5-го загруженного тикера задержка iDelay*3 сек.
Application.Wait Now + TimeSerial(0, 0, iDelay * 3) 'задержка iDelay*3 сек.
DoEvents 'передача ресурсов системы другим процессам
Else: 'иначе, после каждого загруженного тикера задержка iDelay сек.
Application.Wait Now + TimeSerial(0, 0, iDelay) 'задержка iDelay сек.
DoEvents 'передача ресурсов системы другим процессам
End If

ticker = dataSheet.Cells(i, iClm).Value 'считывание имени тикера в ячейке
If ticker <> "" Then 'если не пустая строка в диапазоне кодов тикеров
Filename = FileFolder & "\" & ticker & ".csv" 'путь, имя отдельного файла для тикера
If Dir(Filename) <> "" Then Kill Filename 'удаление старого файла, с проверкой его существования
'Загрузка данных отдельными файлами
DownloadFile "http://table.finance.yahoo.com/table.csv?" & "s=" & ticker & "&a=" & a & "&b=" & b _
& StrURL & "&c=" & c & "&d=" & d & "&e=" & e & StrURL & "&f=" & f & "&g=d&ignore=.csv", Filename
End If
Next i

Application.Calculation = xlAutomatic 'включаем автоматический пересчёт в книге
Application.ScreenUpdating = True 'включаем обновление экрана

'сообщение
MsgBox "Готово!" & vbNewLine _
& "Путь к загруженным данным: " & FileFolder & vbNewLine _
& "Время выполнения макроса: " & (Timer - t) * 1000 & " msec", 65, "Макрос: YahooUpload_2"

End Sub
.
Tags: excel, trade, vba
Subscribe
  • Post a new comment

    Error

    default userpic

    Your IP address will be recorded 

    When you submit the form an invisible reCAPTCHA check will be performed.
    You must follow the Privacy Policy and Google Terms of use.
  • 0 comments