wimgielis.com

Evolutie eredivisie

• 06/11/2011

	Voorbeeldbestanden bij dit artikel:
	Evolutie eredivisie

Inleiding

Uit interesse ben ik nog wat verder gegaan met de code en opzet van een recent artikel: rang en evolutie. Lees dat artikel best door vooraleer dit artikel te lezen, we bouwen verder op de aangeleerde technieken. In dat andere artikel hadden we het over hoe een staat presteert t.o.v. de andere staten wat betreft bevolkingsaangroei of -afgroei. Visueel werd via de gele duidelijk of een staat eerder hoog of laag scoort, en ook hoe die rang wijzigt doorheen de jaren.

Eredivisie voetbal

Jullie weten dat ik wel in voetbal geïnteresseerd ben; dit artikel gaat even over de grens kijken naar de eredivisie voetbal. Op basis van de uitslagen van de wedstrijden (en enkel dat) gaan we proberen inzichtelijk maken hoe een team opschuift of zakt in de rangschikking. Met andere woorden, wat is de plaats in het klassement na elke speeldag?

Gebruik

De bedoeling is dat we een ploegnaam selecteren in kolom A (zie screenshot hierna), en dan hadden we graag de evolutie in beeld gebracht. De pijlen op de illustratie en in het Excel bestand zijn Shapes. Een andere reden voor dit artikel, is dat ik tot nog toe weinig VBA-code met Shapes op mijn site gezet heb. Bij deze kunnen jullie dan de code daarvoor bestuderen en gebruiken.

Het uitvoeren van code na het veranderen van de selectie, heet in Excel VBA een Worksheet_SelectionChange event. Excel detecteert dat de selectie gewijzigd werd, en laat jou toe om programmacode uit te voeren net op dat moment.

PSV

Nemen we de gegevens van PSV even ter hand (rij 13 in de spreadsheet). Kolommen B tot K tonen de uitslagen van PSV in de eerste 10 competitiewedstrijden van het seizoen 2011-2012. Kolommen M tot V zetten die standen om in de puntenevolutie van PSV: verlies op speeldag 1, dus 0 punten in totaal. Winst op speeldagen 2, 3 en 4, zodat het puntentotaal aandikt tot 3, 6, 9 punten. Gelijkspel op speeldag 5, en dan komt PSV op 10 punten. Enz. Na 10 speeldagen telt PSV 21 punten.

De prestaties doorheen het seizoen

Speeldag na speeldag zullen teams stijgen of dalen in de rangschikking. Mijn betrachting is het om die informatie mee te tonen in de kolommen M tot V. Dus GEEN extra tabel of berekeningen in de spreadsheet. We zullen de rang bepalen van een team in een speeldag, en een pijl gebruiken om de evolutie te tonen. Concreet komt dit voor PSV neer op:

• plaats 14 na speeldag 1 (cel M15 is geel, dat is de 14^de cel van bovenaf)
• plaats 7 na speeldag 2 (cel N8 is geel, dat is de 7^de cel van bovenaf)
• plaats 5 na speeldag 3 (cel O6 is geel, dat is de 5^de cel van bovenaf)
• plaats 3 na speeldag 4 (cel P4 is geel, dat is de 3^de cel van bovenaf)
• plaats 5 na speeldag 4 (cel Q6 is geel, dat is de 5^de cel van bovenaf)
• enz.
• na speeldag 10 staat PSV op de 2^de plaats (kolom W)

VBA-code

Wat is de VBA-code hierachter? Bekijk de code gerust in het bestand dat je bovenaan de pagina kan downloaden.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
' Wim Gielis
' https://www.wimgielis.com
'''''
' Worksheet_SelectionChange event code
' 28/10/11
'''''
    If Target.Count = 1 Then

        If Not Application.Intersect(Target, ActiveSheet.UsedRange.Columns(1)) Is Nothing Then

            Call HighlightEvolution(Target)

        End If

    End If

End Sub

Die is alvast het Worksheet_SelectionChange event. Daarbij kan je gebruik maken van de variabele Target, die we meegeven aan de procedure HighlightEvolution. Je mag slechts 1 cel (ploeg) selecteren. Cel A1 doet dienst als "reset cel": klik die aan en de kleuren en shapes verdwijnen.

Sub HighlightEvolution(rngTeam As Range)
' Wim Gielis
' https://www.wimgielis.com
    Const iNR_OF_TEAMS As Integer = 18
    Const sADDRESS_WEEKS As String = "M1:V1"
    Const sSHAPE_NAME As String = "Evolutie"

    Dim rngWeek As Range
    Dim lRank As Long
    Dim l As Long
    Dim rngCelPoints_0 As Range
    Dim rngCelPoints_1 As Range
    Dim sCellsOfRanks() As String

    'remove highlighting and arrows
    ColorArea Range("B2").Resize(iNR_OF_TEAMS, Range(sADDRESS_WEEKS).Count), 0, 0
    ColorArea Range(sADDRESS_WEEKS).Offset(1).Resize(iNR_OF_TEAMS), 0, 0
    On Error Resume Next
    ActiveSheet.Shapes(sSHAPE_NAME).Delete
    On Error GoTo 0

    'apply formatting again, cell A1 acts as the "reset cell"
    If rngTeam.Row > 1 Then

        ReDim sCellsOfRanks(Range(sADDRESS_WEEKS).Count - 1)

        'loop through the years of the dataset and record the cells for later use
        For Each rngWeek In Range(sADDRESS_WEEKS)

            lRank = WorksheetFunction.Rank(Cells(rngTeam.Row, rngWeek.Column), rngWeek.Offset(1).Resize(iNR_OF_TEAMS))
            sCellsOfRanks(rngWeek.Column - Range(sADDRESS_WEEKS).Column) = rngWeek.Offset(lRank).Address

        Next

        For l = 0 To UBound(sCellsOfRanks)

            'relative ranks in yellow
            Set rngCelPoints_0 = Range(sCellsOfRanks(l))
            ColorArea rngCelPoints_0, 6, 6

            'arrows to mark the evolution
            If l < UBound(sCellsOfRanks) Then
                Set rngCelPoints_1 = Range(sCellsOfRanks(l + 1))
            Else
                Set rngCelPoints_1 = Range(sCellsOfRanks(l)).Offset(, 1)
            End If

            With ActiveSheet.Shapes.AddLine(rngCelPoints_0.Left + rngCelPoints_0.Width / 2, _
                                            rngCelPoints_0.Top + rngCelPoints_0.Height / 2, _
                                            rngCelPoints_1.Left + rngCelPoints_1.Width / 2, _
                                            rngCelPoints_1.Top + rngCelPoints_1.Height / 2)

                .Line.Weight = 1.5
                .Line.EndArrowheadStyle = msoArrowheadTriangle

                'trace the name to group shapes later on
                sCellsOfRanks(l) = .Name

            End With

        Next

        ActiveSheet.Shapes.Range(sCellsOfRanks).Group.Name = sSHAPE_NAME

        'aggregated values in green
        ColorArea Range("B" & rngTeam.Row).Resize(, Range(sADDRESS_WEEKS).Count), 43, 0
        ColorArea Range(sADDRESS_WEEKS).Offset(rngTeam.Row - Range(sADDRESS_WEEKS).Row), 43, 0

    End If

End Sub

Private Sub ColorArea(rng As Range, lInteriorColor As Long, lFontColor As Long)
    rng.Interior.ColorIndex = lInteriorColor
    rng.Font.ColorIndex = lFontColor

End Sub

Schrik niet van al die code, gebruik een breakpoint en F8 om in VBA meer inzicht te krijgen in de code. Deel 1 van de code zal de huidige opmaak (kleuren en pijlen) wegnemen. Vervolgens zullen we dan een lus maken doorheen de speeldagen: voor de gekozen ploeg (PSV bijvoorbeeld) bepalen we de rang en kleuren we de cel geel. We tekenen tevens de pijl voor de evolutie: de eigenschappen Top, Left, Height en Width van een cel bepalen waar een pijl precies begint en stopt.

Shapes

Niet vergeten dat we ook in een array de namen van de shapes; zo kunnen we later makkelijk in 1 statement alle shapes groeperen en houden we 1 (grote) shape over in plaats van 10 shapes (de 10 pijlen worden gegroepeerd tot 1 shape). Dit biedt als voordeel dat bestaande pijlen deleten makkelijk kan aangezien we toch maar 1 object ons interesseert. Kijk ook even naar de aparte kleine procedure voor het zetten van kleurtjes (of wegnemen van kleurtjes, casu quo).

• « Vorig Excel artikel
• Volgend Excel artikel »