Thanks Berite, here is your code (x3) for the 3 leagues, though only your original works correctly! It fails on the 2nd one with "Subscript out of range".
I basically duplicated the 3 stages of code, allocating them each 2 sheets to work with, so Premierleague is now on sheet1 (sheet2 as dump) ELO on sheet3 (sheet4 as dump) and SPL sheet5 (sheet6 as dump).
I added the extra stages to Main(), and checked the links and table references. Tables are all the same for each league, just the urls change.
I noticed a couple of things though which will add a spanner to the works:
- BBC have now added a line saying some games are postponed (see ELO below)
- As the season draws to a close there will be less and less tables, eventually only one. Disregard this as I will just amend the webtables="1,2,3,4" in the last 3 months. Currently SPL only has 3 left.
Here is the amended code:
Const sheetName = "Sheet2"
Const sheetNameELO = "Sheet4"
Const sheetNameSPL = "Sheet6"
Sub Main()
ImportFromWeb
TidyUp
SeparateDates
ImportFromWebELO
TidyUpELO
SeparateDatesELO
ImportFromWebSPL
TidyUpSPL
SeparateDatesSPL
End Sub
Sub SeparateDates()
Dim lr As Long
Dim i As Long
With Sheets("Sheet1")
lr = .Range("A" & .Rows.Count).End(xlUp).Row
For i = lr To 1 Step -1
If i <> 1 Then
If .Range("A" & i).Value <> .Range("A" & i - 1).Value Then
Rows(i).Insert shift:=xlDown
Rows(i).Insert shift:=xlDown
Rows(i).Insert shift:=xlDown
End If
End If
Next i
End With
End Sub
Sub TidyUp()
Dim lr As Long
Dim i As Long
Dim txt As String
Dim rw As Long
rw = 1
With Sheets(sheetName)
.Range("E1").Value = "Date"
.Range("F1").Value = "Fixture"
.Range("G1").Value = "Kick Off"
lr = .Range("A" & Rows.Count).End(xlUp).Row
For i = 4 To lr
If .Range("B" & i).Value <> "" Then
txt = .Range("A" & i).Value & " v " & .Range("A" & i + 2).Value
rw = rw + 1
.Range("E" & rw).Value = .Range("B" & i).Value
.Range("F" & rw).Value = txt
.Range("G" & rw).Value = .Range("C" & i).Text
End If
Next i
End With
With Sheets(sheetName)
lr = .Range("A" & .Rows.Count).End(xlUp).Row
.Columns("A:D").Delete shift:=xlToLeft
.Columns("A:C").AutoFit
End With
'copy and paste
Sheets(sheetName).UsedRange.Copy _
Destination:=Sheets("Sheet1").Range("A1")
End Sub
Sub ImportFromWeb()
With Sheets(sheetName).QueryTables.Add(Connection:= _
"URL;http://www.bbc.co.uk/sport/football/premier-league/fixtures", _
Destination:=Sheets(sheetName).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 = "1,2,3,4"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
Sheets(sheetName).Columns(1).Delete shift:=xlToLeft
End Sub
Sub SeparateDatesELO()
Dim lr As Long
Dim i As Long
With Sheets("Sheet3")
lr = .Range("A" & .Rows.Count).End(xlUp).Row
For i = lr To 1 Step -1
If i <> 1 Then
If .Range("A" & i).Value <> .Range("A" & i - 1).Value Then
Rows(i).Insert shift:=xlDown
Rows(i).Insert shift:=xlDown
Rows(i).Insert shift:=xlDown
End If
End If
Next i
End With
End Sub
Sub TidyUpELO()
Dim lr As Long
Dim i As Long
Dim txt As String
Dim rw As Long
rw = 1
With Sheets(sheetNameELO)
.Range("E1").Value = "Date"
.Range("F1").Value = "Fixture"
.Range("G1").Value = "Kick Off"
lr = .Range("A" & Rows.Count).End(xlUp).Row
For i = 4 To lr
If .Range("B" & i).Value <> "" Then
txt = .Range("A" & i).Value & " v " & .Range("A" & i + 2).Value
rw = rw + 1
.Range("E" & rw).Value = .Range("B" & i).Value
.Range("F" & rw).Value = txt
.Range("G" & rw).Value = .Range("C" & i).Text
End If
Next i
End With
With Sheets(sheetNameELO)
lr = .Range("A" & .Rows.Count).End(xlUp).Row
.Columns("A:D").Delete shift:=xlToLeft
.Columns("A:C").AutoFit
End With
'copy and paste
Sheets(sheetNameELO).UsedRange.Copy _
Destination:=Sheets("Sheet3").Range("A1")
End Sub
Sub ImportFromWebELO()
With Sheets(sheetNameELO).QueryTables.Add(Connection:= _
"URL;http://www.bbc.co.uk/sport/football/league-one/fixtures", _
Destination:=Sheets(sheetNameELO).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 = "1,2,3,4"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
Sheets(sheetName2).Columns(1).Delete shift:=xlToLeft
End Sub
Sub SeparateDatesSPL()
Dim lr As Long
Dim i As Long
With Sheets("Sheet5")
lr = .Range("A" & .Rows.Count).End(xlUp).Row
For i = lr To 1 Step -1
If i <> 1 Then
If .Range("A" & i).Value <> .Range("A" & i - 1).Value Then
Rows(i).Insert shift:=xlDown
Rows(i).Insert shift:=xlDown
Rows(i).Insert shift:=xlDown
End If
End If
Next i
End With
End Sub
Sub TidyUpSPL()
Dim lr As Long
Dim i As Long
Dim txt As String
Dim rw As Long
rw = 1
With Sheets(sheetNameSPL)
.Range("E1").Value = "Date"
.Range("F1").Value = "Fixture"
.Range("G1").Value = "Kick Off"
lr = .Range("A" & Rows.Count).End(xlUp).Row
For i = 4 To lr
If .Range("B" & i).Value <> "" Then
txt = .Range("A" & i).Value & " v " & .Range("A" & i + 2).Value
rw = rw + 1
.Range("E" & rw).Value = .Range("B" & i).Value
.Range("F" & rw).Value = txt
.Range("G" & rw).Value = .Range("C" & i).Text
End If
Next i
End With
With Sheets(sheetNameSPL)
lr = .Range("A" & .Rows.Count).End(xlUp).Row
.Columns("A:D").Delete shift:=xlToLeft
.Columns("A:C").AutoFit
End With
'copy and paste
Sheets(sheetNameSPL).UsedRange.Copy _
Destination:=Sheets("Sheet5").Range("A1")
End Sub
Sub ImportFromWebSPL()
With Sheets(sheetNameSPL).QueryTables.Add(Connection:= _
"URL;http://www.bbc.co.uk/sport/football/scottish-premier/fixtures", _
Destination:=Sheets(sheetNameSPL).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 = "1,2,3"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
Sheets(sheetNameSPL).Columns(1).Delete shift:=xlToLeft
End Sub
