Ошибка com 70 разрешение отклонено

ТЛ; др;

Одной из сразу очевидных проблем является повторное создание экземпляров IE, когда нужен только один. Permission denied Это может произойти по ряду причин, включая неправильное обращение с предметами или их утилизацию.

Ниже показано, как:

1. Работать эффективнее с одним экземпляром IE
2. Используйте вспомогательную функцию для сбора всех URL-адресов для посещения и фильтрации по интересующим странам
3. Правильно получить liga оценить и назначить страну country переменная
4. Точно перейдите на страницы и между вкладками. Просто конкатенация суффикса, например #bts;2 не оказался надежным для меня со страницей почти всегда по умолчанию на вкладке по умолчанию #1X2;2, Ниже клики / использование событий развернуты для достижения необходимой навигации
5. Применить на основе условий ожидает присутствия контента с демонстрацией временного цикла, а также цикла, ожидающего изменения значения атрибута
6. Уменьшите ввод-вывод и значительно увеличьте время выполнения, сохраняя результаты в массиве и записывая этот массив, results Один раз на лист. Записать элемент за раз на листе — дорогостоящая операция ввода-вывода
7. Используйте более быстрые CSS-селекторы, для которых оптимизированы современные браузеры

Предостережения:

• Протестировано со всеми ссылками, но есть возможность ужесточить код
• Вероятно, вам может потребоваться ожидание на основе условий для каждого события (нажатие /FireEvent) на странице. Я продемонстрировал множество из них.

Пример содержимого массива результатов (расширен 1 индекс):

Пустые индексы намеренно оставляются для отражения желаемого формата вывода. Один дополнительный столбец для country добавляется в конце.

Пример вывода:

Требования:

1. VBE> Инструменты> Ссылки> Добавить ссылку на Microsoft HTML Object Library

VBA:

Option Explicit
'VBE > Tools > References:
' Microsoft Internet Controls
Public Sub GetOddsInfo()
    Dim ie As New InternetExplorer, url As String, matches()
    Dim i As Long, results(), ws As Worksheet, headers()
    Const MAX_WAIT_SEC As Long = 10
    url = "https://www.oddsportal.com/matches/soccer/20190423/"
    Set ws = ThisWorkbook.Worksheets("Plan1")
    headers = Array("Jogo", vbNullString, "Home Odds", "Draw odds", "Away Odds", vbNullString, "BTT", _
                    "NBTT", vbNullString, "O2", "U2", vbNullString, "Liga", "Country")

    With ie
        .Visible = True
        .Navigate2 url

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

        matches = GetMatches(url, .document)
        ReDim results(1 To UBound(matches, 1), 1 To 14)

        For i = LBound(matches, 1) To UBound(matches, 1)

            .Navigate2 matches(i, 4)             ' default is "#1X2;2"

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

            Dim equipas As String, liga As String, averages As Object, oddH As String, oddD As String, oddA As String
            Dim country As String
            country = matches(i, 1)
            liga = matches(i, 2)
            equipas = matches(i, 3)
            Set averages = .document.querySelectorAll(".aver td")
            oddH = "'" & averages.item(1).innerText 'to ensure odds are correctly formatted on output
            oddD = "'" & averages.item(2).innerText
            oddA = "'" & averages.item(3).innerText
            Set averages = Nothing

            If .document.querySelectorAll("[onclick*='uid\(13\)'], [onmousedown*='uid\(13\)']").Length > 1 Then
                On Error Resume Next
                .document.querySelector("[onclick*='uid\(13\)']").FireEvent "onclick" 'both teams to score
                .document.querySelector("[onmousedown*='uid\(13\)']").FireEvent "onmousedown"
                On Error GoTo 0

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

                Dim oddBtts  As String, oddNbtts As String, t As Date

                t = Timer
                Do
                    On Error Resume Next
                    Set averages = .document.querySelectorAll(".aver td")
                    On Error GoTo 0
                    If Timer - t > MAX_WAIT_SEC Then Exit Do
                Loop While averages.Length < 2

                If averages.Length > 1 Then
                    oddBtts = "'" & averages.item(1).innerText
                    oddNbtts = "'" & averages.item(2).innerText
                End If
            Else
                oddBtts = "No odds"
                oddNbtts = "No odds"
            End If
            Set averages = Nothing
            Dim oddOver As String, oddUnder As String

            If .document.querySelector("#bettype-tabs li:nth-of-type(5)").getAttribute("style") = "display: block;" Then

                .document.querySelector("#bettype-tabs li:nth-of-type(5) span").FireEvent "onmousedown" 'over/under

                Do
                Loop Until .document.querySelector(".table-chunk-header-dark").getAttribute("style") = "display: block;"

               If .document.querySelectorAll("[onclick*='P-2.50-0-0']").Length = 0 Then
                   oddOver = "No odds"
                   oddUnder = "No odds"
               Else

                .document.querySelector("[onclick*='P-2.50-0-0']").Click

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


                Set averages = .document.querySelectorAll(".aver td")
                oddOver = "'" & averages.item(2).innerText
                oddUnder = "'" & averages.item(3).innerText

                End If

            Else
                oddOver = "No odds"
                oddUnder = "No odds"
            End If

            Set averages = Nothing

            Dim resultsPositions(), resultsOrder(), j As Long
            resultsPositions = Array(1, 3, 4, 5, 7, 8, 10, 11, 13, 14) 'columns in output
            resultsOrder = Array(equipas, oddH, oddD, oddA, oddBtts, oddNbtts, oddOver, oddUnder, liga, country)

            For j = LBound(resultsPositions) To UBound(resultsPositions)
                results(i, resultsPositions(j)) = resultsOrder(j)
            Next
            'If i = 5 Then Stop                   ''for testing
        Next
        .Quit
    End With
    With ws
        .Cells(1, 1).Resize(1, UBound(headers) + 1) = headers
        .Cells(2, 1).Resize(UBound(results, 1), UBound(results, 2)) = results
    End With
End Sub

Public Function GetMatches(ByVal url As String, ByVal doc As Object) As Variant
    Dim results(), i As Long, listings As Object, html As HTMLDocument
    Dim countries(), liga As String, country As String, equipas As String, include As Boolean
    Set html = New HTMLDocument

    countries = Array("Argentina", "Austria", "Belgium", "Brazil", "China", "Denmark", "England", _
                      "Finland", "France", "Germany", "Greece", "Ireland", "Italy", "Japan", "Netherlands", "Norway", _
                      "Poland", "Portugal", "Russia", "Scotland", "Spain", "Sweden", "Switzerland", "Turkey", "USA")

    Set listings = doc.querySelectorAll("#table-matches tr")
    Dim games As Object, r As Long
    Set games = doc.querySelectorAll(".table-participant a")
    ReDim results(1 To games.Length, 1 To 4)     'country, liga, equipas, url

    For i = 0 To listings.Length - 1
        html.body.innerHTML = listings.item(i).innerHTML
        Select Case listings.item(i).className
        Case "dark center"
            country = Trim$(html.querySelector(".bfl").innerText)
            liga = html.querySelector(".bflp + a").innerText
            include = Not IsError(Application.Match(country, countries, 0))
        Case "odd deactivate"
            If include Then
                r = r + 1
                results(r, 1) = country
                results(r, 2) = liga
                results(r, 3) = html.querySelector("a").innerText
                results(r, 4) = Replace$(html.querySelector("a").href, "about:", "https://www.oddsportal.com")
            End If
        Case " deactivate"
            If include Then
                r = r + 1
                results(r, 1) = country
                results(r, 2) = liga
                results(r, 3) = html.querySelector("a").innerText
                results(r, 4) = Replace$(html.querySelector("a").href, "about:", "https://www.oddsportal.com")
            End If
        End Select
    Next
    results = Application.Transpose(results)
    ReDim Preserve results(1 To UBound(results, 1), 1 To r)
    results = Application.Transpose(results)
    GetMatches = results
End Function