Hi,
I have a macro that was written for me some years back by a user, that scraped data from a website.
It is now in need of updating as the website has updated/changed a little.
basically i get sports results and fixtures from the website, usually 2 or 3 times per week.
It was set up so that i could get a whole range of dates of results or fixtures. i.e. results for a certain month etc, each would return on a different tab for each day.
Would also be great to get results for just a particular league too.
data used to return in this format
Date League Fixture Team1 Team2
28.10.2017 Africa: CAF Champions League Al Ahly - Wydad Al Ahly Wydad
28.10.2017 Albania: Super League Lushnja - Teuta Lushnja Teuta
28.10.2017 Albania: Super League Skenderbeu - Luftetari Gjirokastra Skenderbeu Luftetari Gjirokastra
displayed in 5 columns, each day on a different tab.
If anybody could help, it would be so greatly appreciated.
Many thanks
Macro is shown below:
I have a macro that was written for me some years back by a user, that scraped data from a website.
It is now in need of updating as the website has updated/changed a little.
basically i get sports results and fixtures from the website, usually 2 or 3 times per week.
It was set up so that i could get a whole range of dates of results or fixtures. i.e. results for a certain month etc, each would return on a different tab for each day.
Would also be great to get results for just a particular league too.
data used to return in this format
Date League Fixture Team1 Team2
28.10.2017 Africa: CAF Champions League Al Ahly - Wydad Al Ahly Wydad
28.10.2017 Albania: Super League Lushnja - Teuta Lushnja Teuta
28.10.2017 Albania: Super League Skenderbeu - Luftetari Gjirokastra Skenderbeu Luftetari Gjirokastra
displayed in 5 columns, each day on a different tab.
If anybody could help, it would be so greatly appreciated.
Many thanks
Macro is shown below:
Code:
Sub Ombir_13Dec16()
Dim i As Long
Dim j As Long
Dim rw As Long
Dim cl As Long
Dim url As String
Dim mdate As String
Dim leagname As String
Dim matchdate As String
Dim output() As String
Dim dt As String
Dim ele As Variant
Dim daterng As Variant
Dim Doc As HTMLDocument
Dim ie As InternetExplorer
Dim league As HTMLTableSection
Dim leagues As IHTMLElementCollection
Dim ws As Worksheet
mdate = InputBox("Enter Match date/dates in dd/mm/yyyy format." & vbCrLf & _
vbCrLf & "For ex :" & vbCrLf & vbCrLf & "14/12/2016" & vbCrLf & vbCrLf & "or" _
& vbCrLf & vbCrLf & "10/12/2016,11/12/2016,12/12/2016,13/12/2016")
If InStr(mdate, ",") Then
daterng = Split(mdate, ",")
Else
ReDim daterng(1 To 1)
daterng(1) = mdate
End If
For Each ele In daterng
If Not IsDate(ele) Then
MsgBox "Incorrect Date"
Exit Sub
End If
dt = Replace(ele, "/", "-")
On Error Resume Next
Set ws = ThisWorkbook.Worksheets(dt)
If ws Is Nothing Then
ThisWorkbook.Worksheets.Add().Name = dt
Set ws = ThisWorkbook.Worksheets(dt)
End If
On Error GoTo 0
ws.UsedRange.Clear
Set ie = New InternetExplorer
url = "http://www.betexplorer.com/results/soccer/?year=" & Split(dt, "-")(2) & "&month=" & Split(dt, "-")(1) & "&day=" & Split(dt, "-")(0)
With ie
.Visible = True
.Navigate url
Do While .Busy Or .ReadyState <> 4: DoEvents: Loop
End With
Set Doc = ie.Document
Set leagues = Doc.getElementsByClassName("table-matches js-nrbanner-t")(0).getElementsByTagName("tbody")
ReDim output(1 To leagues.Length * 15, 1 To 11)
i = 0
For Each league In leagues
With league
If .className <> "js-nrbanner-tbody h-display-none" Then
leagname = Application.Clean(.Children(0).innerText)
matchdate = Doc.getElementsByClassName("in-date-navigation__cal js-window-trigger")(0).innerText
For rw = 1 To .Rows.Length - 1
j = 0
If .Rows(rw).className <> "js-newdate" Then
i = i + 1: j = j + 1
output(i, j) = matchdate
output(i, j + 1) = leagname
output(i, j + 2) = .Rows(rw).Cells(0).Children(0).innerText
output(i, j + 3) = .Rows(rw).Cells(0).Children(1).innerText
output(i, j + 4) = Split(output(i, j + 3), "- ")(0)
output(i, j + 5) = Split(output(i, j + 3), "- ")(1)
j = 7
For cl = 1 To .Rows(rw).Cells.Length - 1
output(i, j) = .Rows(rw).Cells(cl).innerText
j = j + 1
Next
Else
matchdate = .Rows(rw).innerText
End If
Next
End If
End With
Next
ie.Quit
ws.Range("A1:K1") = Array("Date", "League", "Time", "Fixture", "Team1", "Team2", "Col1", "Col2", "Col3", "Col4", "Col5")
ws.Range("A1:K1").Interior.ThemeColor = xlThemeColorAccent1
ws.Range("A2").Resize(UBound(output, 1), UBound(output, 2)) = output
With ws.UsedRange
.Columns.AutoFit
.Borders.Weight = xlThin
.WrapText = False
End With
Set ws = Nothing
Next
End Sub
Last edited by a moderator:
