aantal, totaal en gemiddeld berekenen

[ikbenbertus]

Hallo

Thuis doe ik veel het spel gesjaakt. m'n vader had hier een simpel schemaatje voor gemaakt om de scores bij te houden. gemiddelden en totale score per potje lukt me wel alleen nou wil ik dat hij van ieder potje de namen herkent en daarbij het aantal potjes dat diegene gespeeld heeft uitrekent, totaalscore van de potjes die hij gespeeld heeft en het gemiddelde van alle potjes per ronde.

ik heb het bij piet al handmatig gedaan alleen dat wil ik dus dat hij automatisch alle "piet" herkent zodat hij aantal potjes, totaal en gemiddeld voor die persoon kan bereken.

dit wil ik bij ieder persoon.

dit is wat ik heb.
link
het lukte me niet om het als bijlage toe te voegen.

 

[wampier]

Er is geen eenvoudige eenduidige oplossing voor. Nu ken ik het spelletje niet, zijn het altijd 5 potjes en maximaal 5 personen? Er is met VBA mogelijk wel een mouw aan te passen, maar de layout moet wel eenduidig zijn.

 

[ikbenbertus]

Met het spelletje kunnen maximaal 5 mensen meedoen, gebeurt dus ook wel dat er minder meedoen. wij spelen altijd 5 rondes per potje.
Wat is VBA? en hoe zou de layout er dan uit moeten zien?

 

[wampier]

VBA is visual basic for applications, de taal waarin "macro's" worden geschreven.

Het makkelijkst zou het zijn als alles onder elkaar stond, maar met de huidige layout lukt het ook wel zolang er niet steeds een kolom wordt bijgeprikt e.d.. Vandaar mijn vraag over het aantal kolommen/spelers. Als ik zo eens tijd heb kan ik wel even kijken of ik wat kan knutselen.

open je testvoorbeeld in excel en druk ALT-F11 ->dit opent een nieuw scherm

ga op het nieuwe scherm naar "invoegen" en kies "module"

in het nieuwe textvlak plak het volgende:

Option Base 0

Type informatie
    naam As String
    potjes As Long
    totaal As Long
    subpot As Long
End Type
Dim gevonden() As informatie


Sub tellen()


ReDim gevonden(0)

For Each cell In ActiveSheet.Range([a1], [a50000].End(xlUp))
    If cell.Value = "naam" Then
        For i = 1 To 5
            a = WorksheetFunction.Count(Range(cell.Offset(1, i), cell.Offset(5, i)))
            Call updatematrix(cell.Offset(0, i), cell.Offset(6, i), a)
        Next i
    End If
    
    If cell.Offset(0, 7).Value = "naam" Then
        For i = 1 To 5
            a = WorksheetFunction.Count(Range(cell.Offset(1, 7 + i), cell.Offset(5, 7 + i)))
            Call updatematrix(cell.Offset(0, 7 + i), cell.Offset(6, 7 + i), a)
        Next i
    End If
            
Next cell

ReDim Preserve gevonden(UBound(gevonden) - 1)
For i = LBound(gevonden) To UBound(gevonden)
    ActiveSheet.Cells(15 + i, 15) = gevonden(i).naam
    ActiveSheet.Cells(15 + i, 16) = gevonden(i).potjes
    ActiveSheet.Cells(15 + i, 17) = gevonden(i).totaal
    ActiveSheet.Cells(15 + i, 18) = gevonden(i).totaal / gevonden(i).subpot
Next i

End Sub

Sub updatematrix(naam As String, totaal As Long, ByVal rondes As Double)
    toevoegen = True
    For i = LBound(gevonden) To UBound(gevonden)
        If naam = gevonden(i).naam Then
            gevonden(i).potjes = gevonden(i).potjes + 1
            gevonden(i).totaal = gevonden(i).totaal + totaal
            gevonden(i).subpot = gevonden(i).subpot + rondes
            toevoegen = False
        End If
    Next i
    If toevoegen Then
        gevonden(UBound(gevonden)).naam = naam
        gevonden(UBound(gevonden)).potjes = 1
        gevonden(UBound(gevonden)).totaal = totaal
        gevonden(UBound(gevonden)).subpot = rondes
        ReDim Preserve gevonden(UBound(gevonden) + 1)
    End If

End Sub

druk nu op F5 en run "tellen"

 

[ikbenbertus]

Bedankt!
Hij werkt goed alleen dat tabelletje begint nu in O15 kan ik dat ook makkelijk veranderen in die macro?

*Edit:
heb het net gevonden, cijfers bij activesheet.cells veranderd en hij doet het.

 

[ikbenbertus]

de macro werkt nog steeds.
maar ik wil nu graag dat hij de macro automatisch uitvoert zodra ik een cel verander, kan dit ook?

 

[wampier]

Open weer VBA met ALT-F11. dubbelclick aan de linkerkant "BLAD1"

In het code veld rechts het volgende plakken:

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column < 14 Then
Call tellen
End If
End Sub

 

[ikbenbertus]

code werkt maar als ik hem ingevoerd heb en ik verander een cel past hij dat aan en dan reageert excel 2010 niet meer.
ligt dat aan de excel die ik heb?

 

[wampier]

Vreemd. Ik heb de code getest op 2007 en daar ondervind ik geen enkel probleem. Mogelijk heb je de uitslag ergens links gezet? Deze code gaat ervan uit dat de uitslag rechts van je inputs staat in niet ergens in kolom A:N

 

[ikbenbertus]

klopt, dit vindt ik overzichtelijker.
maar hij berekent alles van kolom 1 tot 14 is toch?
dan zou hij de uitslag inderdaad ook weer berekenen waardoor hij oneindig blijft berekenen.

is de code makkelijk te veranderen waardoor hij vanaf A;15 berekend?
zodat ik de uitslag kan laten staan.

*Edit
heb column in row veranderd en < in > en hij doet het nu!

 

[ikbenbertus]

Kun je ook (alleen als je er zin in hebt, hoeft niet) in die VBA een code zetten zodat hij ook automatisch berekend hoeveel potjes diegene gewonnen heeft?
wie de laagste score heeft totaal (bij 1 potje) heeft gewonnen.

gesjaakt bestand

 

[wampier]

In principe is dat wel mogelijk. Ik heb helaas de komende dagen geen tijd om er echt naar te kijken in verband met een zakenreis.

De macro neemt al naam en totaal per potje. Het is een kwestie van per potje nog meegeven wie er dan gewonnen heeft. Mogelijk heb ik ergens nog tijd om er wat tijd in te steken.

 

[ikbenbertus]

dat zou mooi zijn,
je moet het alleen doen als je er zin in hebt!

 

[wampier]

Het enige probleem dat ik echt zie is als twee mensen exact dezelfde score hebben. in dat geval "wint" de linker persoon. nu is dat ook wel te ondervangen, maar vraagt wat meer logica. beide kunnen winnen of niemand.

 

[ikbenbertus]

als je het lukt dat beide dan winnen is dat goed anders is het pech en doe je het maar dat niemand wint. dan moet ik die score zelf maar aanpassen

 

[wampier]

Het is een flinke lap text geworden. Ik werd een beetje nostalgisch om dit op te lossen buiten mijn normale object-oriented talen. Het was makkelijker op te lossen met een extra global, maar het was zo leuk om weer eens met dit soort functies te prutsen dat ik het niet kon laten.

Option Base 0

Type informatie
    naam As String
    potjes As Long
    totaal As Long
    subpot As Long
    wins As Long
End Type
Dim gevonden() As informatie
Dim winnaam() As String

Sub tellen()

ReDim gevonden(0)
ReDim winnnaam(0)
Dim score As Long
score = 9999
For Each cell In ActiveSheet.Range([a1], [a50000].End(xlUp))
    If cell.Value = "naam" Then
        For i = 1 To 5
            a = WorksheetFunction.Count(Range(cell.Offset(1, i), cell.Offset(5, i)))
            Call updatematrix(cell.Offset(0, i), cell.Offset(6, i), a)
            score = winnaar(cell.Offset(0, i), cell.Offset(6, i), i, score)
        Next i
    End If
    
    If cell.Offset(0, 7).Value = "naam" Then
        For i = 1 To 5
            a = WorksheetFunction.Count(Range(cell.Offset(1, 7 + i), cell.Offset(5, 7 + i)))
            Call updatematrix(cell.Offset(0, 7 + i), cell.Offset(6, 7 + i), a)
            score = winnaar(cell.Offset(0, 7 + i), cell.Offset(6, 7 + i), i, score)
        Next i
    End If
            
Next cell

ReDim Preserve gevonden(UBound(gevonden) - 1)
For i = LBound(gevonden) To UBound(gevonden)
    ActiveSheet.Cells(6 + i, 2) = gevonden(i).naam
    ActiveSheet.Cells(6 + i, 3) = gevonden(i).potjes
    ActiveSheet.Cells(6 + i, 4) = gevonden(i).totaal
    On Error Resume Next
    ActiveSheet.Cells(6 + i, 5) = gevonden(i).totaal / gevonden(i).subpot
    ActiveSheet.Cells(6 + i, 6) = gevonden(i).wins
Next i

End Sub

Sub updatematrix(naam As String, totaal As Long, ByVal rondes As Double)
    toevoegen = True
    For i = LBound(gevonden) To UBound(gevonden)
        If naam = gevonden(i).naam Then
            gevonden(i).potjes = gevonden(i).potjes + 1
            gevonden(i).totaal = gevonden(i).totaal + totaal
            gevonden(i).subpot = gevonden(i).subpot + rondes
            toevoegen = False
        End If
    Next i
    If toevoegen Then
        gevonden(UBound(gevonden)).naam = naam
        gevonden(UBound(gevonden)).potjes = 1
        gevonden(UBound(gevonden)).totaal = totaal
        gevonden(UBound(gevonden)).subpot = rondes
        ReDim Preserve gevonden(UBound(gevonden) + 1)
    End If

End Sub

Function winnaar(naam As String, score As Long, ByVal speler As Long, tussenstand As Long) As Long
If naam = "" Or score = 0 Then
    winnaar = tussenstand
    GoTo finaleval
Else
    If score < tussenstand Then
        ReDim winnaam(0)
        winnaam(0) = naam
        winnaar = score
    End If
    If score > tussenstand Then
        winnaar = tussenstand
    End If
    If score = tussenstand Then
        ReDim Preserve winnaam(UBound(winnaam) + 1)
        winnaam(UBound(winnaam)) = naam
        winnaar = score
    End If
End If

finaleval:
If speler = 5 Then
    winnaar = 9999
    For Each winner In winnaam
        For j = LBound(gevonden) To UBound(gevonden)
            If winner = gevonden(j).naam Then
                gevonden(j).wins = gevonden(j).wins + 1
            End If
        Next j
    Next winner
    ReDim winnaam(0)
End If

End Function

 

[ikbenbertus]

hij werkt prima !
dank je wel, opnieuw.
ik probeer dit soort dingen zelf ook wel uit te zoeken maar dan moet ik er meer tijd in gaan steken en dat heb ik niet.
maar ik vind het wel leuk om hiermee te prutsen

 

[wampier]

Ach het is gewoon een mindset hoor. Het is niet iets dat je verleerd. Als ik het nu nog zou moeten oppakken zou ik er wel een paar keer over denken, maar ik heb meer dan 20 jaar hobbyen achter de rug en dat maakt het weel makkelijker. Gisteren geschreven in mijn hotelkamertje. Er is maar zoveel sudoku en angry birds wat je in een week kan verdragen