Question

亲爱的

使用以下代码，我试图更改datepicker日期，但收到错误。如果您能提供任何解决方案/更正，我将很高兴。

@QHarr我想在几个月前遵循您给出的示例。

非常感谢您的关注。

Sub Download_Historical_Data()

Dim DateToUse As String, ChampionName As String

Dim IE As InternetExplorer, doc As HTMLDocument, games As Object
Dim i As Long, j As Long

'Loop until you reach the day before today
Do Until wsControl.Range("B1").Value = Format$(Date - 1, "DD-MM")
    'Initialize project. Check the LastDate and if it is null we use "2018 - 01 - 01" and import the it in wsControl.Range("B1").Value
    If wsControl.Range("B1").Value = "" Then
        DateToUse = Format$("01-01-2018", "DD-MM")
        wsControl.Range("B1").Value = DateToUse
    Else
        DateToUse = Format(wsControl.Range("B1").Value + 1, "DD-MM")
    End If

    'Open Browser and download data
    Set IE = New InternetExplorer

    With IE
        .Visible = True
        .Navigate ("https://www.xscores.com/soccer/livescores/" & DateToUse)

        While .Busy Or .readyState < 4: DoEvents: Wend

        Set doc = .document

    End With

    Set games = doc.getElementsByClassName("game_table")

    IE.Quit
    Set IE = Nothing

Loop

End Sub

Answer 1

长方法：

通过点击月份（后退箭头）和日期（通过循环日历中的日期并选择适当的日期）来浏览此内容

通过网站设计，您只能直接选择当前日期之前最多2周的日期。我已经添加了一个技巧来解决这个问题，这使得元素可以选择，但是遗憾的是，任何早于两周的日期都将默认返回最新日期数据。

Option Explicit  
Public Sub DateSelection()
    'Max past date is 2 weeks prior to today's date
    Dim dateToUse As String, lastSundayPriorMonth As Long, numberOfIndicesToIgnore As Long
    dateToUse = "2018-09-28"

    If Not IsDateValid(dateToUse) Then
        MsgBox "Please select a date between " & Format$(DateAdd("ww", -2, Date) + 1, "yyyy-mm-dd") & " and " & Format$(Date, "yyyy-mm-dd")
        Exit Sub
    End If

    lastSundayPriorMonth = GetLastSunday(DateAdd("m", -1, CDate(dateToUse)))
    numberOfIndicesToIgnore = Abs(CDate(dateToUse) - lastSundayPriorMonth) '<==Dates from prior month to ignore on displayed calendar

    Dim dates As Object, ie As InternetExplorer, i As Long
    Set ie = New InternetExplorer

    With ie
        .Visible = True
        .navigate "https://www.xscores.com/soccer/livescores"

        While .Busy Or .readyState < 4: DoEvents: Wend

        With .document

            Dim numberOfMonthsInPast As Long

            numberOfMonthsInPast = GetNumberOfMonthsBack(dateToUse)

            .querySelector(".dateDetails").Click

            If numberOfMonthsInPast > 0 Then               
                For i = 1 To numberOfMonthsInPast 'navigate back the required number of months
                    .querySelector(".calendar-prev").Click
                    While ie.Busy Or ie.readyState < 4: DoEvents: Wend
                Next
            End If

            Set dates = .querySelectorAll(".calendar-dates [class^=date]") '<== All dates in selected month view

            For i = numberOfIndicesToIgnore To dates.Length - 1
                If CInt(dates.item(i).innerText) = Day(dateToUse) Then
                    dates.item(i).querySelector("a").Click 
                    While ie.Busy Or ie.readyState < 4: DoEvents: Wend
                    Exit For
                End If
            Next
            'other code
        End With
        Stop                                     '<==Delete me later
        .Quit
    End With
End Sub

Public Function GetLastSunday(ByVal dateString As String) As Long
    Dim d As Date
    d = DateSerial(YEAR(dateString), Month(dateString) + 1, 1) - 1
    GetLastSunday = d - Weekday(d) + 1
End Function

Public Function IsDateValid(ByVal dateString As String) As Boolean
    IsDateValid = (DateDiff("ww", dateString, Date) >= 0 And DateDiff("ww", dateString, Date) <= 2)
End Function

Public Function GetNumberOfMonthsBack(ByVal dateString As String) As Long
    GetNumberOfMonthsBack = DateDiff("m", dateString, Date)
End Function

首选：

仅通过使用URL中的dd-mm，我似乎仍然能够获得较早的日期，但是我很欣赏这似乎会为您带来可变的结果（通常默认为最新数据）。

Option Explicit
Public Sub test()
    Dim ie As New InternetExplorer
    With ie
        .Visible = True
        .navigate "https://www.xscores.com/soccer/livescores/19-09"

        While .Busy Or .readyState < 4: DoEvents: Wend

        Stop '<== Delete me later
        .Quit
    End With
End Sub

2018年10月3日至今的数据（顶部行）：

2018年9月19日的手动选择日期（顶部行）：

代码运行时间为2018-09-19：

单轮：

Option Explicit
Public Sub DateSelection()
    'Max past date is 2 weeks prior to today's date
    Dim dateToUse As String, lastSundayPriorMonth As Long, numberOfIndicesToIgnore As Long
    dateToUse = "2018-09-18"

    lastSundayPriorMonth = GetLastSunday(DateAdd("m", -1, CDate(dateToUse)))
    numberOfIndicesToIgnore = Abs(CDate(dateToUse) - lastSundayPriorMonth) '<==Dates from prior month to ignore on displayed calendar

    Dim dates As Object, ie As InternetExplorer, i As Long
    Set ie = New InternetExplorer

    With ie
        .Visible = True
        .navigate "https://www.xscores.com/soccer/livescores"

        While .Busy Or .readyState < 4: DoEvents: Wend

        With .document

            Dim numberOfMonthsInPast As Long

            numberOfMonthsInPast = GetNumberOfMonthsBack(dateToUse)

            .querySelector(".dateDetails").Click

            If numberOfMonthsInPast > 0 Then
                For i = 1 To numberOfMonthsInPast 'navigate back the required number of months
                    .querySelector(".calendar-prev").Click
                    While ie.Busy Or ie.readyState < 4: DoEvents: Wend
                Next
            End If

            Set dates = .querySelectorAll(".calendar-dates [class^=date]") '<== All dates in selected month view

            For i = numberOfIndicesToIgnore To dates.Length - 1
                If CInt(dates.item(i).innerText) = Day(dateToUse) Then
                    If Not IsDateWithin2Weeks(dateToUse) Then
                        With dates.item(i)
                            .outerHTML = Replace(dates.item(i).outerHTML, " disabled", vbNullString)
                            Set dates = ie.document.querySelectorAll(".calendar-dates [class^=date]") '<== All dates in selected month view
                        End With
                    End If
                    dates.item(i).querySelector("a").Click

                    While ie.Busy Or ie.readyState < 4: DoEvents: Wend
                    Exit For
                End If
            Next
            'other code
        End With
        Stop                                     '<==Delete me later
        .Quit
    End With
End Sub

Public Function IsDateWithin2Weeks(ByVal dateString As String) As Boolean
    IsDateWithin2Weeks = (DateDiff("ww", dateString, Date) >= 0 And DateDiff("ww", dateString, Date) <= 2)
End Function

使用VBA从HTML日期选择器中选择日期

1 个答案: