Omat Visual Basic -taidot on aika keskinkertaiset, mutta netissä törmäsin muutamaan
'siistiin' koodinpätkään. Pientä Leikkaa/Liimaa -näpräilyä ja sain kasaan toimivan makro-koodin.
Makro hakee betexplorer.com'in sivuilta eri liigojen ottelutulokset ja tulevan ohjelman ja
yhdistelee ne omille välilehdilleen. Tässä mukana ovat vain pohjoismaitten käynnissä olevat
liigat, mutta koodia on perustiedoillakin helppo laajentaa muihin sarjoihin.
Turvallisuus:
Makroja Excel-taulukoissa ei tietenkään yleisesti pidä sallia niihin sisältyvien turvariskien vuoksi.
Käytännöllinen tapa toimia makrojen suhteen on määritellä kansio, jossa luotettu
makrotiedosto sijaitsee 'Luotettavaksi sijainniksi' (Trusted Locations), eli
Office Button => Excel Options => Trust Center => Trust Center Settings => Trusted Locations
(mitä mahtavat olla suomeksi...?)
Latausosoite: (päivitettävänä)
Rar-password: ylikerroin.com
Kätevä ja välttämätön apuväline kaikille rajojen laskijoille.
Allekirjoittaneen luotettavuudesta en menisi takuuseen, mutta ehkä luotettavuutta vähän parantaa kun laitan lähdekoodin tähän loppuun:
Koodi: Valitse kaikki
Option Explicit
Sub Button1_Click()
Download (1)
End Sub
Sub Button2_Click()
Download (2)
End Sub
Sub Button3_Click()
Download (3)
End Sub
Sub Button4_Click()
Download (4)
End Sub
Sub Button5_Click()
Download (5)
End Sub
Sub Button6_Click()
Download (6)
End Sub
Sub Button7_Click()
Download (7)
End Sub
Sub Button8_Click()
Download (8)
End Sub
Sub Button9_Click()
Download (9)
End Sub
Sub Button10_Click()
Download (10)
End Sub
Sub Button11_Click()
Download (11)
End Sub
Sub Button12_Click()
Download (12)
End Sub
Private Sub Download(buttonnumber As Integer)
Application.ScreenUpdating = False
'DOWNLOAD DATA FROM BETEXPLORER
Dim strResUrls(1 To 200) As String
strResUrls(1) = "http://www.betexplorer.com/soccer/finland/finnish-1st-veikkausliiga-2011/results/"
strResUrls(2) = "http://www.betexplorer.com/soccer/finland/finnish-2nd-league-2011/results/"
strResUrls(3) = "http://www.betexplorer.com/soccer/sweden/swedish-1st-allsvenskan-2011/results/"
strResUrls(4) = "http://www.betexplorer.com/soccer/sweden/swedish-2nd-superettan-2011/results/"
strResUrls(5) = "http://www.betexplorer.com/soccer/norway/norwegian-1st-eliteserien-2011/results/"
strResUrls(6) = "http://www.betexplorer.com/soccer/norway/norwegian-2nd-league-2011/results/"
strResUrls(101) = "http://www.betexplorer.com/soccer/finland/finnish-1st-veikkausliiga-2011/fixtures/"
strResUrls(102) = "http://www.betexplorer.com/soccer/finland/finnish-2nd-league-2011/fixtures/"
strResUrls(103) = "http://www.betexplorer.com/soccer/sweden/swedish-1st-allsvenskan-2011/fixtures/"
strResUrls(104) = "http://www.betexplorer.com/soccer/sweden/swedish-2nd-superettan-2011/fixtures/"
strResUrls(105) = "http://www.betexplorer.com/soccer/norway/norwegian-1st-eliteserien-2011/fixtures/"
strResUrls(106) = "http://www.betexplorer.com/soccer/norway/norwegian-2nd-league-2011/fixtures/"
Dim URLValue As String
Sheets("DataRes").Activate
URLValue = strResUrls(buttonnumber)
Range("A:J").Select
Selection.Clear
With ActiveSheet.QueryTables.Add(Connection:="URL;" & URLValue, Destination:=Range("$A$1"))
.Name = "TEMP1"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlOverwriteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = False
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "1"
.WebPreFormattedTextToColumns = False
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = True
.WebDisableRedirections = True
.Refresh BackgroundQuery:=False
End With
Sheets("DataFix").Activate
URLValue = strResUrls(100 + buttonnumber)
Range("A:J").Select
Selection.Clear
With ActiveSheet.QueryTables.Add(Connection:="URL;" & URLValue, Destination:=Range("$A$1"))
.Name = "TEMP2"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlOverwriteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = False
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "1"
.WebPreFormattedTextToColumns = False
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = True
.WebDisableRedirections = True
.Refresh BackgroundQuery:=False
End With
FormatData (buttonnumber)
End Sub
Private Sub FormatData(buttonnumber As Integer)
'PREPARE LEAGUE SHEET
Dim strLeagues(1 To 100) As String
strLeagues(1) = "Fin1"
strLeagues(2) = "Fin2"
strLeagues(3) = "Swe1"
strLeagues(4) = "Swe2"
strLeagues(5) = "Nor1"
strLeagues(6) = "Nor2"
Dim FinalRow As Long
Sheets(strLeagues(buttonnumber)).Activate
Cells.Clear
Range("A1:I1").Select
With Selection
.Font.Bold = True
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
End With
Range("A1").Select
ActiveCell.FormulaR1C1 = "RESULTS"
Range("B1").Select
ActiveCell.FormulaR1C1 = "HOME"
Range("C1").Select
ActiveCell.FormulaR1C1 = "AWAY"
Range("D1").Select
ActiveCell.FormulaR1C1 = "H"
Range("E1").Select
ActiveCell.FormulaR1C1 = "A"
Range("G1").Select
ActiveCell.FormulaR1C1 = "FIXTURES"
Range("H1").Select
ActiveCell.FormulaR1C1 = "HOME"
Range("I1").Select
ActiveCell.FormulaR1C1 = "AWAY"
'RESULT FORMULAS
Sheets("DataRes").Activate
Range("K2").Select
ActiveCell.FormulaR1C1 = "=IF(IFERROR(FIND("". Round"",RC[-10]),"""")<>"""",1,"""")"
Range("L2").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-1]=1,1,IF(R[-1]C=1,1,""""))"
Range("M2").Select
ActiveCell.FormulaR1C1 = "=IF(IFERROR(FIND(""postp."",RC[-11]),"""")="""",IF(RC[-7]<>"""",IF(RC[-1]=1,SUBSTITUTE(RC[-7],""."",""/"")*1,""""),""""),"""")"
Range("N2").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-1]<>"""",LEFT(RC[-13],FIND("" - "",RC[-13])-1),"""")"
Range("O2").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-2]<>"""",RIGHT(RC[-14],(LEN(RC[-14])-FIND("" - "",RC[-14]))-2),"""")"
Range("P2").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-3]<>"""",HOUR(RC[-14]),"""")"
Range("Q2").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-4]<>"""",MINUTE(RC[-15]),"""")"
Range("K2:Q2").Select
Selection.Copy
FinalRow = Range("A500000").End(xlUp).Row + 3
Range("K2:Q" & FinalRow).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("M2:M" & FinalRow).Select
Selection.NumberFormat = "dd/mm/yyyy;@"
FinalRow = Range("A500000").End(xlUp).Row + 3
ActiveSheet.Range("$M$2:$Q$" & FinalRow).AutoFilter Field:=1, Criteria1:="<>"
Range("$M$2:$Q$" & FinalRow).Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
'COPY DATA TO LEAGUESHEET
Sheets(strLeagues(buttonnumber)).Activate
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
'SORT
FinalRow = Range("A500000").End(xlUp).Row
ActiveWorkbook.Worksheets(strLeagues(buttonnumber)).Sort.SortFields.Clear
ActiveWorkbook.Worksheets(strLeagues(buttonnumber)).Sort.SortFields.Add Key:=Range("A2:A" & FinalRow), _
SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets(strLeagues(buttonnumber)).Sort.SortFields.Add Key:=Range("B2:B" & FinalRow), _
SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets(strLeagues(buttonnumber)).Sort
.SetRange Range("A1:E" & FinalRow)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A2:E" & FinalRow).Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlGeneral
End With
'FIXTURE FORMULAS
Sheets("DataFix").Activate
Range("K2").Select
ActiveCell.FormulaR1C1 = "=IF(IFERROR(FIND("" - "",RC[-9]),"""")<>"""",1,"""")"
Range("L2").Select
ActiveCell.FormulaR1C1 = "=IFERROR(SUBSTITUTE(LEFT(RC[-11],10),""."",""/"")*1,"""")"
Range("M2").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-1]="""",R[-1]C,RC[-1])"
Range("N2").Select
ActiveCell.FormulaR1C1 = "=IF(AND(RC[-1]<>0,RC[-1]<>"""",RC[-3]=1),RC[-1],"""")"
Range("O2").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-1]<>"""",LEFT(RC[-13],FIND("" - "",RC[-13])-1),"""")"
Range("P2").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-2]<>"""",RIGHT(RC[-14],LEN(RC[-14])-(FIND("" - "",RC[-14])+2)),"""")"
Range("K2:P2").Select
Selection.Copy
FinalRow = Range("A500000").End(xlUp).Row + 3
Range("K2:P" & FinalRow).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("N2:N" & FinalRow).Select
Selection.NumberFormat = "dd/mm/yyyy;@"
FinalRow = Range("A500000").End(xlUp).Row + 3
ActiveSheet.Range("$N$2:$P$" & FinalRow).AutoFilter Field:=1, Criteria1:="<>"
Range("$N$2:$P$" & FinalRow).Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
'COPY DATA TO LEAGUESHEET
Sheets(strLeagues(buttonnumber)).Activate
Range("G2").Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Cells.EntireColumn.AutoFit
Range("A2").Select
Sheets("DataRes").Activate
Selection.AutoFilter
Cells.Select
Selection.Delete Shift:=xlUp
Range("A1").Select
Sheets("DataFix").Activate
Selection.AutoFilter
Cells.Select
Selection.Delete Shift:=xlUp
Range("A1").Select
Sheets(strLeagues(buttonnumber)).Activate
Application.ScreenUpdating = True
End Sub
Minikommentit