использование vba для зацикливания столбца дат в строке URL-адреса для веб-запроса и получения таблицы обменных курсов из xe.com/currencytables

Question

У меня есть столбец дат (в электронной таблице Excel), и я хотел бы вставить эти даты в строку URL-адреса в веб-запросе, чтобы сгенерировать таблицы обменных курсов, которые я хотел бы поместить в электронные таблицы. Например:

Столбец A 2019-12-09 2019-12-08 2019-12-07

Для каждой из этих дат в столбце A я хотел бы вставить их в строку URLНиже приведен записанный макрос VBA с использованием --Get Data из Интернета. Затем я копирую и вставляю https://www.xe.com/currencytables/?from=USD&date=2019-12-10 в URL (всплывающее окно), нажимаю ОК и выбираю таблицу 0, чтобы сгенерировать таблицу курсов валют на дату 2019-12-10. Я хотел бы автоматизировать этот процесс и использовать даты в столбце А. У меня нет опыта в силовых запросах. Спасибо за вашу помощь заранее.

Sub Macro2()
'
' Macro2 Macro
'

'
    ActiveWorkbook.Queries.Add Name:="Table 0 (6)", Formula:= _
        "let" & Chr(13) & "" & Chr(10) & "    Source = Web.Page(Web.Contents(""https://www.xe.com/currencytables/?from=USD&date=2019-12-08""))," & Chr(13) & "" & Chr(10) & "    Data0 = Source{0}[Data]," & Chr(13) & "" & Chr(10) & "    #""Changed Type"" = Table.TransformColumnTypes(Data0,{{""Currency code ??"", type text}, {""Currency name ??"", type text}, {""Units per USD"", type number}, {""USD per Unit"", type number}})" & Chr(13) & "" & Chr(10) & "in" & Chr(13) & "" & Chr(10) & "    #""Changed Type"""
    ActiveWorkbook.Worksheets.Add
    With ActiveSheet.ListObjects.Add(SourceType:=0, Source:= _
        "OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=""Table 0 (6)"";Extended Properties=""""" _
        , Destination:=Range("$A$1")).QueryTable
        .CommandType = xlCmdSql
        .CommandText = Array("SELECT * FROM [Table 0 (6)]")
        .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_0__6"
        .Refresh BackgroundQuery:=False
    End With

End Sub

Answer 1

Для теста я изменил URL:

    ActiveWorkbook.Queries.Add Name:="Table 0 (6)", Formula:= _
    "let" & Chr(13) & "" & Chr(10) & "    Source = Web.Page(Web.Contents(""https://www.xe.com/currencytables/?from=USD&date=" & Format(DateSerial(2019, 12, 8), "yyyy-mm-dd") & """))," & Chr(13) & "" & Chr(10) & "    Data0 = Source{0}[Data]," & Chr(13) & "" & Chr(10) & "    #""Changed Type"" = Table.TransformColumnTypes(Data0,{{""Currency code"", type text}, {""Currency name"", type text}, {""Units per USD"", type number}, {""USD per Unit"", type number}})" & Chr(13) & "" & Chr(10) & "in" & Chr(13) & "" & Chr(10) & "    #""Changed Type"""
ActiveWorkbook.Worksheets.Add

Таким образом, в формате (dateserial ()) вы можете поместить свою переменную с датой из ячейки.

У меня естьтакже изменились Код валюты ?? и Имя валюты ?? на Код валюты и Название валюты и отредактировали их вручную в редакторе силовых запросов вАналогично Excel, так как существует проблема с этими стрелками в именах столбцов.

Если вы хотите создать таблицы для всех дат одновременно, то вам нужно решить эту проблему с помощью стрелок в имени столбца (или это уже решено?).

Следующим шагом является обеспечение того, чтобы имена таблиц были уникальными и генерировались автоматически.

Последним шагом будет цикл for, проходящий через ячейки с датами.

---

ОБНОВЛЕНИЕ:

Хорошо, ниже вы можете найти обновленный код. Я удалил форматирование столбцов для проблемных столбцов со специальными символами. Переменные для имени таблицы и даты созданы, поэтому теперь будет чрезвычайно легко расширить этот код для создания таблиц того, сколько исторических данных вы хотите:)

Option Explicit

Sub DownloadExchangeRates()
    'Set variables
        Dim wb As Workbook
        Dim wbs As Worksheet

        Dim mydate As Date
        Dim table_name As String
        Dim table_display_name As String

        Set wb = ThisWorkbook

        mydate = DateSerial(2019, 12, 7)
        table_name = "Table " & Format(mydate, "yyyy-mm-dd")
        table_display_name = "Table_" & Format(mydate, "yyyy_mm_dd")

    ' Create connection
        wb.Queries.Add _
            Name:=table_name, _
            Formula:= _
            "let" & Chr(13) & "" & Chr(10) & _
            "    Source = Web.Page(Web.Contents(""https://www.xe.com/currencytables/?from=USD&date=" & Format(mydate, "yyyy-mm-dd") & """))," & Chr(13) & "" & Chr(10) & _
            "    Data0 = Source{0}[Data]," & Chr(13) & "" & Chr(10) & _
            "    #""Changed Type"" = Table.TransformColumnTypes(Data0,{{""Units per USD"", type number}, {""USD per Unit"", type number}})" & Chr(13) & "" & Chr(10) & _
            "in" & Chr(13) & "" & Chr(10) & _
            "    #""Changed Type"""

    'Create new worksheet
        wb.Worksheets.Add
        Set wbs = wb.ActiveSheet
        wbs.Name = "Currency for " & Format(mydate, "yyyy-mm-dd")

        With wbs.ListObjects.Add(SourceType:=0, Source:= _
            "OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=" & """" & table_name & """" & ";Extended Properties=""""" _
            , Destination:=Range("$A$1")).QueryTable
            .CommandType = xlCmdSql
            .CommandText = Array("SELECT * FROM [" & table_name & "]")
            .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_display_name
            .Refresh BackgroundQuery:=False
        End With

End Sub