Web Scraping Add problem in list

fredrerik84

Active Member
Joined
Feb 26, 2017
Messages
383
Hi I would like to start this thread to thank the community here and especially Domenic for helping me together the code bellow:

Rich (BB code):
Rich (BB code):
    Set HTMLDoc = IE.document
Sub testing2()




    Dim IE As New SHDocVw.InternetExplorer
    Dim HTMLDoc As New MSHTML.HTMLDocument
    Dim HTMLRows As MSHTML.IHTMLElementCollection
    Dim HTMLRow As MSHTML.IHTMLElement
    Dim League As String
    Dim sheet As Worksheet
    Dim r As Long
    Dim i As Long
    Dim j As Long
    Dim K As Long
    Dim vMatch As Variant
    
    
    Set sheet = ActiveWorkbook.Sheets("Conversion")
    IE.Navigate "http://www.xscores.com/soccer/scheduled_games/24-05"
    IE.Visible = True
    
With IE
        Do While .Busy Or .readyState <> READYSTATE_COMPLETE
            DoEvents
        Loop
    End With
    
    Set HTMLDoc = IE.document
    Set HTMLRows = HTMLDoc.getElementById("scoretable").getElementsByTagName("tr")
    
    Columns("B:F").ClearContents
     Columns("B:F").Borders.LineStyle = xlNone
    
    r = 2
    For i = 0 To HTMLRows.Length - 3
        If HTMLRows(i).Cells.Length - 1 >= 10 Then
            Cells(r, "B").Value = HTMLRows(i).Cells(0).innerText
            Cells(r, "B").Borders(xlEdgeLeft).Color = RGB(91, 155, 213)
            League = HTMLRows(i).Cells(IIf(i > 0, 4, 3)).innerText
            Cells(r, "C").Value = League
            vMatch = Application.VLookup(League, sheet.Range("V1:X62"), 3, False)
            If Not IsError(vMatch) Then
                Cells(r, "C").Value = vMatch
            Else
                Cells(r, "C").Value = League
            End If
            Cells(r, "D").Value = HTMLRows(i).Cells(IIf(i > 0, 5, 4)).innerText & " (" & HTMLRows(i).Cells(IIf(i > 0, 6, 5)).innerText & ")"
            If i > 0 Then
                Cells(r, "E").Value = GetCountry(HTMLRows(i).Cells(3).getElementsByTagName("a")(0).getAttribute("title"))
            Else
                Cells(r, "E").Value = "Country"
            End If
            Cells(r, "F").Value = HTMLRows(i).Cells(IIf(i > 0, 9, 7)).innerText & " (" & HTMLRows(i).Cells(IIf(i > 0, 10, 8)).innerText & ")"
            Cells(r, "F").Borders(xlEdgeRight).Color = RGB(91, 155, 213)
            r = r + 1
        End If
    Next i
    Cells(r - 1, 2).Resize(, 5).Borders(xlEdgeBottom).Color = RGB(91, 155, 213)
    MsgBox i - 4 & " Matches has been Loaded.", vbInformation
    IE.Quit
    Set HTMLDoc = Nothing
    Set HTMLRows = Nothing
    Set HTMLRow = Nothing
    
End Sub

but I have made some changes to this code as this page has also "all_games" link so the line in red above will be: IE.Navigate "http://www.xscores.com/soccer/all_games/24-05" but this gives following problem: as this is just as summerize page for Finished_games, Live_games and up_comming games so this site handles this with adding an Add in the middle of the list. , Is there an way/code I can try to jump over this without going into infinite loop Any help would be greatly appreciated , my sulltion is to run the code from 3 links but I relly hope there is an better way

 
Last edited:
Hi , thank you for your response , Unfortunately I got an error msg with this function

"Error 91: Object variable or with block variable not set"
 
Upvote 0

Excel Facts

What does custom number format of ;;; mean?
Three semi-colons will hide the value in the cell. Although most people use white font instead.
That's probably because you're processing a row that should be excluded. Make sure that line of code occurs after...

Code:
If i = 0 Or IsDate(sKO) Then
 
Upvote 0
hmmmm... I have it replaced after, this code have been crazy long but here ir is:

Rich (BB code):
    R = 2
    Columns("F").NumberFormat = "@"
    For i = L To HTMLRows.Length - 1
        sKO = HTMLRows(i).Cells(0).innerText
        If i = 0 Or IsDate(sKO) Then
            Cells(R, "B").Value = sKO
            Cells(R, "B").Borders(xlEdgeLeft).Color = RGB(91, 155, 213)
            League = HTMLRows(i).Cells(IIf(i > 0, 4, 3)).innerText
            vMatch = Application.VLookup(League, sheet.Range("V1:X62"), 3, False)
            Cells(R, "D").Value = GetLeague(HTMLRows(i).Cells(4).getElementsByTagName("a")(0).getAttribute("on_click"))


            If Not HTMLRows(i).Cells(IIf(i > 0, 6, 5)).innerText = "" Then
                Cells(R, "E").Value = HTMLRows(i).Cells(IIf(i > 0, 5, 4)).innerText & " (" & HTMLRows(i).Cells(IIf(i > 0, 6, 5)).innerText & ")"
            Else
                Cells(R, "E").Value = HTMLRows(i).Cells(IIf(i > 0, 5, 4)).innerText
            End If
            If i > 0 Then
                Cells(R, "C").Value = GetCountry(HTMLRows(i).Cells(3).getElementsByTagName("a")(0).getAttribute("title"))
                Cells(R, "C").Replace ")", ""
                Cells(R, "C").Replace "(", ""
            Else
                Cells(R, "C").Value = "Country"
            End If
            Cells(R, "F").Value = HTMLRows(i).Cells(IIf(i > 0, 14, 11)).innerText
            If Not HTMLRows(i).Cells(IIf(i > 0, 10, 8)).innerText = "" Then
                Cells(R, "G").Value = HTMLRows(i).Cells(IIf(i > 0, 9, 7)).innerText & " (" & HTMLRows(i).Cells(IIf(i > 0, 10, 8)).innerText & ")"
            Else
                Cells(R, "G").Value = HTMLRows(i).Cells(IIf(i > 0, 9, 7)).innerText
            End If
            Cells(R, "G").Borders(xlEdgeRight).Color = RGB(91, 155, 213)
            R = R + 1
        End If
    Next i
    Cells(R - 1, 2).Resize(, 6).Borders(xlEdgeBottom).Color = RGB(91, 155, 213)
    blnSuccessful = True
    
ExitHandler:
    If Not IE Is Nothing Then
        IE.Quit
    End If
    
    With Application
        .DisplayAlerts = True
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    
    Application.Cursor = xlDefault
    Application.StatusBar = False
    Set IE = Nothing
    Set HTMLDoc = Nothing
    Set HTMLRows = Nothing
    Set HTMLRow = Nothing
    Set sheet = Nothing
    
    If blnSuccessful Then
        MsgBox i - MSG & " Matches has been Loaded.", vbInformation
    End If
    
    Exit Sub
    
ErrHandler:
    If Len(strErrMsg) > 0 Then
        MsgBox strErrMsg, vbCritical, "Error"
        GoTo ExitHandler
    Else
        If Err <> 0 Then
            MsgBox "Error " & Err.Number & ":  " & Err.Description, vbCritical, "Error"
            Resume ExitHandler
        End If
    End If
    
End Sub




 Sub Clear()
     Dim sheet As Worksheet
     
     Columns("B:G").ClearContents
     Columns("B:G").Borders.LineStyle = xlNone
     Cells(2, "B").Value = "K/O"
     Cells(2, "C").Value = "Country"
     Cells(2, "D").Value = "League"
     Cells(2, "E").Value = "Home (LP)"
     Cells(2, "F").Value = "-"
     Cells(2, "G").Value = "Away (LP)"
 End Sub
Function GetCountry(ByVal sTitle As String) As String
    Dim sCountry As String
    sCountry = Mid(sTitle, InStrRev(sTitle, " ") + 1)
    GetCountry = sCountry
End Function
Function GetLeague(ByVal sLeagueData As String) As String
    Dim sLeague As String
    sLeague = Mid(sLeagueData, InStr(1, sLeagueData, "','") + 3)
    sLeague = Left(sLeague, InStr(1, sLeague, "','") - 1)
    GetLeague = sLeague
End Function

I was supposed to remove the underscore? (I have tried with and without)
 
Upvote 0
Yes, remove the underscore. But you'll have to move that line as follows...

Code:
    R = 2
    Columns("F").NumberFormat = "@"
    For i = L To HTMLRows.Length - 1
        sKO = HTMLRows(i).Cells(0).innerText
        If i = 0 Or IsDate(sKO) Then
            Cells(R, "B").Value = sKO
            Cells(R, "B").Borders(xlEdgeLeft).Color = RGB(91, 155, 213)
            League = HTMLRows(i).Cells(IIf(i > 0, 4, 3)).innerText
            vMatch = Application.VLookup(League, Sheet.Range("V1:X62"), 3, False)
            If Not HTMLRows(i).Cells(IIf(i > 0, 6, 5)).innerText = "" Then
                Cells(R, "E").Value = HTMLRows(i).Cells(IIf(i > 0, 5, 4)).innerText & " (" & HTMLRows(i).Cells(IIf(i > 0, 6, 5)).innerText & ")"
            Else
                Cells(R, "E").Value = HTMLRows(i).Cells(IIf(i > 0, 5, 4)).innerText
            End If
            If i > 0 Then
                Cells(R, "C").Value = GetCountry(HTMLRows(i).Cells(3).getElementsByTagName("a")(0).getAttribute("title"))
                Cells(R, "C").Replace ")", ""
                Cells(R, "C").Replace "(", ""
                [COLOR=#ff0000]Cells(R, "D").Value = GetLeague(HTMLRows(i).Cells(4).getElementsByTagName("a")(0).getAttribute("on_click"))[/COLOR]
            Else
                Cells(R, "C").Value = "Country"
            End If
            Cells(R, "F").Value = HTMLRows(i).Cells(IIf(i > 0, 14, 11)).innerText
            If Not HTMLRows(i).Cells(IIf(i > 0, 10, 8)).innerText = "" Then
                Cells(R, "G").Value = HTMLRows(i).Cells(IIf(i > 0, 9, 7)).innerText & " (" & HTMLRows(i).Cells(IIf(i > 0, 10, 8)).innerText & ")"
            Else
                Cells(R, "G").Value = HTMLRows(i).Cells(IIf(i > 0, 9, 7)).innerText
            End If
            Cells(R, "G").Borders(xlEdgeRight).Color = RGB(91, 155, 213)
            R = R + 1
        End If
    Next i
 
Upvote 0

Forum statistics

Threads
1,215,400
Messages
6,124,702
Members
449,180
Latest member
craigus51286

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top