Question

我制作了从URL中检索数据的宏脚本。我需要的是，我需要逐个增加日期并获取每个数据。 URL是这样的：

  https://www.ukdogracing.net/racecards/01-05-2017/monmore

我可以使用此脚本获取数据：

  Sub GetData()
    Dim IE As Object
    Dim doc As Object
    Dim strURL As String
    Dim I As Integer

    For I = 1 To 5
    strURL = "https://www.ukdogracing.net/racecards/01-05-2017/monmore" + Trim(Str(I))

    Set IE = CreateObject("InternetExplorer.Application")
    With IE

    .navigate strURL
    Do Until .ReadyState = 4: DoEvents: Loop
    Do While .Busy: DoEvents: Loop
    Set doc = IE.Document
    GetAllTables doc

    .Quit

    End With
    Next I

    End Sub


    Sub GetAllTables(doc As Object)

    Dim ws As Worksheet
    Dim rng As Range
    Dim tbl As Object
    Dim rw As Object
    Dim cl As Object
    Dim tabno As Long
    Dim nextrow As Long
    Dim I As Long
    Dim ThisLink As Object 'variable for <a> tags
    Set ws = Worksheets.Add

    For Each tbl In doc.getElementsByTagName("TABLE")
        tabno = tabno + 1
        nextrow = nextrow + 1
        Set rng = ws.Range("B" & nextrow)

        rng.Offset(, -1) = "Table " & tabno
        For Each rw In tbl.Rows
            For Each cl In rw.Cells
                rng.Value = cl.outerText
                Set rng = rng.Offset(, 1)
                I = I + 1
            Next cl
        nextrow = nextrow + 1
        Set rng = rng.Offset(1, -I)
        I = 0
        Next rw
    Next tbl

    I = Range("B" & Rows.Count).End(xlUp).Row 'last row with data

    Do While Cells(I, 1).Value = "" 'will loop until first not blank found in column A (starting from last row of data, from end to start)
        For Each ThisLink In doc.getElementsByTagName("a") 'we check all <a> tags
            If ThisLink.innerText = Cells(I, 2).Value Then Cells(I, 1).Value = ThisLink.href 'If the innertext is the name of the race, in column A we add link
        Next ThisLink
        I = I - 1 'we decrease row position
    Loop
    End Sub

但是我需要脚本获取URL的日期部分并且每次添加一天直到今天并获取数据。例如：

 https://www.ukdogracing.net/racecards/01-06-2017/monmore 

 https://www.ukdogracing.net/racecards/01-07-2017/monmore

等...如何使脚本获取每天添加一个的数据。

提前致谢。

Answer 1

用这一个替换第一个子，它将运行指定的日期。我无法看到I有任何目的，所以我将其删除了。

Sub GetData()
    Dim IE As Object, doc As Object
    Dim strURL As String, myDate As Date

    Set IE = CreateObject("InternetExplorer.Application")
    With IE

        For myDate = CDate("01-05-2017") To CDate("01-09-2017")

            strURL = "https://www.ukdogracing.net/racecards/" & Format(myDate, "mm-dd-yyyy") & "/monmore" ' Trim(Str(I))
            .navigate strURL
            Do Until .ReadyState = 4: DoEvents: Loop
            Do While .Busy: DoEvents: Loop
            Set doc = IE.Document
            GetAllTables doc

        Next myDate

        .Quit
    End With
End Sub

自动增加宏中URL中间的日期

1 个答案: