VBA retrieve football fixtures from web

EMcK01

Board Regular
Joined
Jun 14, 2015
Messages
125
Hi,

Looking for some help updating some vba code that Bertie had previously helped me out with. The code provided was as follows:

Code:
Sub Main()
   Dim rng As Range
   Dim sUrl As String
   Dim sSheetName As String
   Dim sNumTables As String
   
   Set rng = Sheets("Data").Range("A6")
   Do Until rng = ""
      sUrl = rng.Value
      sSheetName = rng.Offset(, 1).Value
      sNumTables = rng.Offset(, 2).Value
      
      ImportFromWeb sUrl, sSheetName, sNumTables
      TidyUp (sSheetName)
      InserBlankRows (sSheetName)
           
      Set rng = rng.Offset(1, 0)
   Loop


End Sub

Code:
Private Sub ImportFromWeb(ByVal sUrl As String, _
                  ByVal sSheetName As String, _
                  ByVal sNumTables As String)
   'copy the template
   Sheets("Template").Copy After:=Worksheets(Worksheets.Count)
   ActiveSheet.Name = sSheetName
   
   With Sheets(sSheetName).QueryTables.Add(Connection:= _
      "URL;" & sUrl, _
      Destination:=Sheets(sSheetName).Range("$A$1"))
      .Name = "fixtures-data"
      .FieldNames = True
      .RowNumbers = False
      .FillAdjacentFormulas = False
      .PreserveFormatting = True
      .RefreshOnFileOpen = False
      .BackgroundQuery = True
      .RefreshStyle = xlInsertDeleteCells
      .SavePassword = False
      .SaveData = True
      .AdjustColumnWidth = True
      .RefreshPeriod = 0
      .WebSelectionType = xlSpecifiedTables
      .WebFormatting = xlWebFormattingNone
      .WebTables = sNumTables
      .WebPreFormattedTextToColumns = True
      .WebConsecutiveDelimitersAsOne = True
      .WebSingleBlockTextImport = False
      .WebDisableDateRecognition = False
      .WebDisableRedirections = False
      .Refresh BackgroundQuery:=False
   End With
End Sub

Code:
Private Sub TidyUp(sSheetName As String)   
'Insert blank column
   For colx = 3 To 6 Step 1
    Columns(colx).Insert shift:=xlToRight
   Next
   
'Delete column
   With Sheets(sSheetName)
        .Columns("H:H").EntireColumn.Delete
    End With
    
   Dim numRows As Long
   Dim arrFixture As Variant
   Dim rw As Long
   With Sheets(sSheetName)
      'get the number of rows
      numRows = .Cells(.Rows.Count, "B").End(xlUp).Row
      
      For rw = 4 To numRows
         
         'test for "V " is in string, if so, split into array and process
         If InStr(.Range("B" & rw).Value, "V ") Then
            arrFixture = Split(.Range("B" & rw).Value, "V ")   'split strin on V followed by space
            
            'output
            .Range("D" & rw).Value = arrFixture(0)
            .Range("E" & rw).Value = "vs."
            .Range("F" & rw).Value = arrFixture(1)
         End If
      Next rw
   End With


The code previously worked as I wanted and downloaded all football fixtures for a chosen league from the BBC football website (Premier League - Scores & Fixtures - Football - BBC Sport). The output is something similar to the below, with home team, "vs." away team and kick off times all in separate columns.

[TABLE="width: 416"]
<tbody>[TR]
[TD]Match Day 01[/TD]
[TD="colspan: 2"]12th August 2017[/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Fixture[/TD]
[TD][/TD]
[TD]Kick-off[/TD]
[/TR]
[TR]
[TD]Arsenal[/TD]
[TD]vs.[/TD]
[TD]Leicester City[/TD]
[TD]15:00[/TD]
[/TR]
[TR]
[TD]Brighton & Hove Albion[/TD]
[TD]vs.[/TD]
[TD]Manchester City[/TD]
[TD]15:00[/TD]
[/TR]
[TR]
[TD]Chelsea[/TD]
[TD]vs.[/TD]
[TD]Burnley[/TD]
[TD]15:00[/TD]
[/TR]
[TR]
[TD]Crystal Palace[/TD]
[TD]vs.[/TD]
[TD]Huddersfield Town[/TD]
[TD]15:00[/TD]
[/TR]
[TR]
[TD]Everton[/TD]
[TD]vs.[/TD]
[TD]Stoke City[/TD]
[TD]15:00[/TD]
[/TR]
</tbody>[/TABLE]

However the BBC have recently changed their website and have split it into fixtures per month rather than listing them for the whole season; and now the vba code no longer downloads the fixtures.

Can anyone advise how this should be updated allow the fixtures to be downloaded again?

I'm not concerned about what web site the fixtures come from if an alternative is more suitable, all I would like is the fixtures to be downloaded as above in separate columns.

Thanks,
EMcK
 

Excel Facts

Move date out one month or year
Use =EDATE(A2,1) for one month later. Use EDATE(A2,12) for one year later.

Forum statistics

Threads
1,223,239
Messages
6,170,947
Members
452,368
Latest member
jayp2104

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