XL 2021 tirage au sort aléatoire sans doublon

[aubaluc]

bonjour
je me penche vers vous car je sèche sur un problème que je vais essayer de vous expliquer clairement
je souhaite effectuer un tirage au sort de 2 tours avec 40 équipes maximum ( le nombre peut être différent )
il faut que dans les 2 tirages il n'y ait pas de doublon c'est à dire que dans chaque match 2 équipes ne se rencontrent pas
j'ai essayé avec la formule ALEA mais je ne suis pas certain de ne pas avoir de doublon
je pense qu'avec une macro se serai plus certain
je vous mets en pièce jointe l'exemple
merci d'avance à celles ou ceux qui voudront bien me dépanner
aubaluc

 

[patricktoulon]

si tes calculs d'echelle sont bons alors tu a une couillete dans ton code dans les classe ou autres , le msgbox est plus que parlant
après tu fait comme tu veux ,mais toi qui veux être precis là tu est loin du compte une telle différence entre le timer et ta méthode ne peut pas être une erreur je vais regarder de plus près

 

[patricktoulon]

re
je ne suis pas sur mais au vu du code ton timer est déclenché au load du userform
de toute facon les api sont dans le userform en private alors ca ne peut ce passer que là
donc a aucun moment les fonctions de l'api sont accessibles ailleurs
conclusion tu compte pas le temps du bon moteur
(pas sur): en fait tu compte le temps de son ouverture
sur: c'est pas le compteur de la fonction qui fait le mélange ça c'est sur

pour démarrer un performancecounter il faudrait que les api soit accessibles via les modules hors elles sont dans le userform en private
du coup je suis sur que ce n'est pas le temps de la sub ou fonction de tri dans le désordre qui est compté
c'est tout bonnement impossible en private dans un userform

au pire je te fait un exemple avec la classe benchmarck si tu veux ou si tu doute encore
elle on la declenche avant on l'arrete après c'est pas compliqué

 

[Dranreb]

Le temps compté est celui écoulé lors de l'appel à UFmVisu.Conclure depuis celui à UFmVisu.DescConfig.
Ces deux méthodes sont naturellement invoquées par la Function Tirage1vs1OK

 

[patricktoulon]

Et voila le test benchmarck
on est dans des temps certes intéressants avec les effets de bords du au repétitions de mes tests mais on est loins des 200 microseconde s

tu es plutôt à 2500 microsecondes puisqu'au benchmarck ca donne 25 millisecondes et pas 25 µf
voila comme ca il n'y a plus d’ambiguïté
quand je ferme et réouvre on repart a 100/120 ms

 

[Dranreb]

Je n'ai aucune confiance alors dans ce mystérieux objet cBenchmark.

 

[patricktoulon]

re testé au benchmarck ton userform augmente le temps de *2.5 environ et pour le coup non seulement le résultats le confirme mais le visuel aussi
quand je remet ton userform aller/retour
et pour le coup aussi je l'utilise en mono taches un start et un stop par le TrackByName
pour info
l'object cbenchmarck c'est une classe qui utilise exactement le même procédé que toi avec les même api

 

[bsalv]

quand je ferme et réouvre on repart a 100/120 ms

cela, je me demandais aussi si souvent l'origine ! La première fois est toujours plus longtemps que la 2ième fois.
Ma macro crée une compétition complète "allez-retour" pour autant de joueurs en 0.100 millisecondes.
Si, un moment plus tard, on veut un tirage avec le même nombre de joueurs, un tirage aléatoir du tableau en colonne C suffit normallement, mais tout est négliable.

 

[patricktoulon]

quand je remet ton userform aller/retour
et pour le coup aussi je l'utilise en mono taches un start et un stop par le TrackByName

pour info
l'object cbenchmarck c'est une classe qui utilise exactement le même procédé que toi avec les même api


après si on raisonne simplement, il est impossible que tout tes modules engagés module standard / classe et userform
mettent exactement 1000 fois moins que que ma simple boucle dans une petite sub (qui je le rappelle est le même procédé que toi)


il n'y a pas besoins d'avoir fait l’école de st Cyr pour le comprendre

25 ms environ pour toi et moi (on a entre 800 et 500 µf d'ecart)et tu peux en être fier avec tout ce que tu engage mais 1000 fois moins non .c'est absurde et tout bonnement impossible

le timer le prouve
le benchmarck le prouve
le visuel le prouve

 

[Dranreb]

Ma méthode UFmVisu.Montre ne consomme guère de temps: Elle rend généralement la main aussitôt sauf tous les 40ms.
Je ne sais pas de quelle boucle tu parles, je n'ai pas vu tes codes.

 

[patricktoulon]

@bsalv
oui des temps comme ca c'est négligeable même 500 ms c'est pas la mer à boire c'est encore acceptable
après c'est dans les gros volume qu'il faut voir si la méthode est rentable et là on voi la différence entre l'une et l'autre

@Dranreb
la classe cbenchmarck
j'ai juste mis les dictionnaires en late binding (pas toucher au moteur )

ca se teste comme ça

'mono tache
sub trucbidulle
dim bm as new cbenchmarck
bm.start
'
'faire quelque chose ici qui prend du temps( y compris appeler des fonctions avec un return)
'
'et ensuite on ferme le track
bm.trackbyname "fin du travail à tester "
end sub

ou en multi taches

'mono tache
sub trucbidulle
dim bm as new cbenchmarck
bm.trackbyname" debut des hostilités partie 1"
'
'faire quelque chose ici qui prend du temps( y compris appeler des fonctions avec un return)
'
bm.trackbyname" fin de la partie  partie 1"
bm.trackbyname" debut de la partie  partie 2"
'
'faire quelque chose ici qui prend du temps( y compris appeler des fonctions avec un return)
'
bm.trackbyname" fin de la partie  partie 2"
bm.trackbyname" debut de la partie  partie 3"
'
'faire quelque chose ici qui prend du temps( y compris appeler des fonctions avec un return)
'


'et ensuite on ferme le track
bm.trackbyname "fin du travail à tester "
set bm=nothing
end sub

''
' VBA-Benchmark v0.1
' Jonathan de Vries - https://github.com/jonadv/VBA-Benchmark/
'
' Benchmark VBA Code

Option Explicit

#If VBA7 Then '64 bit
    Private Declare PtrSafe Function QueryPerformanceCounter Lib "kernel32" (stamp As Currency) As Byte
    Private Declare PtrSafe Function QueryPerformanceFrequency Lib "kernel32" (freq As Currency) As Byte
#Else '32 bit
    Private Declare Function QueryPerformanceCounter Lib "kernel32" (stamp As Currency) As Byte
    Private Declare Function QueryPerformanceFrequency Lib "kernel32" (freq As Currency) As Byte
#End If

'About the chosen datatype: The fastest possible way (as in with least amount of overhead)
'to store qpc stamps is to store them in an array as datatype Currency (or as LongLong).
'Storing the stamps as a UDT (fe LARGE_INTEGER.lowpart and .highpart) takes much longer,
'as basically two 'seperate' primary datavalues have to be stored. Surprisingly there is no difference
'in time at all in using either LongLong or Currency, however, datatype LongLong is not availabe
'on 32-bit machines. Reverting of Currency-returns is required, but that is done after benchmarking
'finished so it will not effect the benchmark results.

'used definitions:
'QPC            QueryPerformanceCounter, reads the TSC and translates it to a timeunit
'stamp          returnvalue from QPC, which is an accurate time-stamp since computer has been boot
'QPF            QueryPerformanceFrequency
'frequency      the amount of QPC-cycles per second, nowadays usually 10MHz on Windows 10 but can differ per machine
'tic            difference between two QPC time stamps
'cpu-cycle      a single increment of the CPU clock during which the smallest unit of processor activity is carried out.
'qpc-cycle      non-exisiting term that just shows how confusing clock cycles are.
'RDTSC          Read Time Stamp Counter, an even more accurate way to benchmark code, but for VBA it would require a custom made .dll

Private freq As Currency 'frequency is the amount tics per second
Private stampCount As Long 'to keep track of postition of next stamp and stampID in arrays
Private currentArraySizes As Long 'to prevent calling Ubound(arrStamps) every time
Private arrStamp() As Currency 'stores QPC stamps
Private arrStampID() As Byte 'stores id numbers of track calls. Byte = 0-255, so max 256 tracks, using Byte forces ID of 0 or above
Private dicStampName_ID As Object 'key = custom name, value = StampID
Private Const fromCurr As Currency = 10000 'QPC and QPF downscale LongLong (actual returntype) with 10000 when they return a value with datatype Currency
Private stamp_ReportEnd As Currency 'is set at end of Report calculation and prevents printing the report when it was less then x amount of seconds ago
Private Const overheadTestCount As Long = 100 'Overhead is tested in a loop. Lowering this ammount a lot might increase overhead because of CPU branching.

Private Enum TrackID
    id_start = 255
    id_continue = 254
    id_pause = 253
    id_resizingarray = 252
End Enum

'TODO: include setting time unit of output (nanos, millis, seconds, etc). calcualte default at end by total time passed

' ============================================= '
' Class specific Functions
' ============================================= '
' @Class_Initialize
' @Class_Terminate
Private Sub Class_Initialize()
    QueryPerformanceFrequency freq 'frequency is set at computer boot, does not change after that
    freq = freq * fromCurr 'scale from Currency to whole number
    Set dicStampName_ID = CreateObject("scripting.dictionary")
    dicStampName_ID.CompareMode = vbBinaryCompare 'faster then vbTextCompare, but difference in capital letters will matter
    Start 'Start stores the first QPC, which is filtered out in Sub Report
End Sub
Private Sub Class_Terminate()
    Report 'print report with default settings when code is finished (to debug immediate window)
End Sub

' ============================================= '
' Public Functions
' ============================================= '
' @TrackByName      - Same as @TrackByTheID but more convenient (and thus with a bit more overhead)
' @TrackByTheID     - Store QPC (cycle counts) in an array
' @Start            - (Start) or (Reset and Restart) benchmark
' @Pause            - Convenience method to exclude pieces of code, use in combination with .Continue
' @Continue         - Use after calling .Pause to continue tracking
' @Report           - Generate report
' @Sleep            - timeout code, alternative for Application.Wait
' @Wait             - same as method Sleep

Public Sub TrackByName(ByVal strTrackName As String)
    'intermediate/more convenient way to call track method (but a few cycles slower)
    'if TrackByTheID and TrackByName are used mixed, some tracks might write to the same ID
    'reference type ByVal can save a few clock cycles https://stackoverflow.com/questions/408101/which-is-faster-byval-or-byref
    
    'when count = 0, it adds an IDnr of 0, count = 1 adds IDnr 1, etc
    If Not dicStampName_ID.Exists(strTrackName) Then dicStampName_ID.Add strTrackName, CByte(dicStampName_ID.Count)
    
    'gets IDnr and passes it as argument when calling TrackByTheID
    TrackByTheID dicStampName_ID(strTrackName)
    
End Sub
Public Sub TrackByTheID(ByVal IDnr As Byte)
    'if it runs into an error here, you probably tried to pass a string data type
    
    'sub was called TrackByID before, but then intellisense shows it as first option/above TrackByName
    'when only typing 'tr'. This way typing 'tr' + tab should be enough.
    
    stampCount = stampCount + 1
    
    'store cpu stampcount in array
    QueryPerformanceCounter arrStamp(stampCount)
    
    'store id nr in seperate samesized array
    arrStampID(stampCount) = IDnr
    
    'check array sizes for next stamp
    If stampCount = currentArraySizes Then
        'required to prevent array out of bound (it's either this
        'if-then or set the arrays to (large) fixed sizes (and still
        'get out of bound error when code is running for longer time))
        
        RedimStampArrays
        
        'redim can be time consuming so exclude this from recording.
        TrackByTheID TrackID.id_resizingarray
    End If
End Sub

Public Sub Start()
    Reset 're-initialize all
    TrackByTheID TrackID.id_start
End Sub
Public Sub Pause()
    'Use in combination with .Continue to exclude code from being tracked
    'Is only included in output of report if boExtendedReport is set to True
    TrackByTheID TrackID.id_pause
End Sub
Public Sub Continue()
    'Use in combination with .Pause to exclude code from being tracked
    'Is only included in output of report if boExtendedReport is set to True
    TrackByTheID TrackID.id_continue
End Sub
Public Sub Report(Optional ByVal boExtendedReport As Boolean = False, _
                  Optional ByVal boTransposeReport As Boolean = False, _
                  Optional ByVal OutputToRange As Range = Nothing, _
                  Optional ByVal boCorrectOverhead As Boolean = False, _
                  Optional ByVal boForceMillis As Boolean = False)
    'Public method of report function. Calculates and outputs report with default settings to debug window (ctrl + G to show).
    'Can be called from Immediate window or in break mode/while running code
    ReportArg boExtendedReport, boTransposeReport, OutputToRange, boCorrectOverhead, boForceMillis
End Sub

Public Sub Sleep(seconds As Double, Optional boDoEventsWhileSleeping As Boolean = True)
    'Same as Application.Wait function, but more accurate and easier to use.
    'a.Sleep 2      <- VS ->     Application.Wait Now + TimeValue("0:00:02")
    'set boDoEventsWhileSleeping to false for even more accuracy
    Dim startstamp As Currency, restamp As Currency
    QueryPerformanceCounter startstamp
    Do While ticsToSeconds(stampsToTics(startstamp, restamp)) <= seconds
        If boDoEventsWhileSleeping Then DoEvents
        QueryPerformanceCounter restamp
    Loop
End Sub
Public Sub Wait(seconds As Double, Optional boDoEventsWhileWaiting As Boolean = True)
    'For when you're used to methodname Wait
    Sleep seconds, boDoEventsWhileWaiting
End Sub

' ============================================= '
' Private Functions - Specific bench helpers
' ============================================= '
' @Reset                - reset/re-initialise all variables
' @RedimStampArrays     - enlarge stamp arrays
' @ReportArg            - calculate and write report

Private Sub Reset()
    'Sub is private as public method .Start does the same
    QueryPerformanceFrequency freq 'Make sure frequency is set right (in case an instance of this class is declared public static)
    freq = freq * fromCurr
    stampCount = 0
    currentArraySizes = 0
    RedimStampArrays
    dicStampName_ID.RemoveAll
End Sub
Private Sub RedimStampArrays()
    Dim enlargementstep As Long: enlargementstep = 262144# '2^18
    'array size in memory = 20 bytes + 4 per dimension + bytes of elements. LongLong and Currency are both 8 byte per element.
    'first call of this sub sets memory usage of both arrays to (20+4+262,144*8=) 2,097,176 byte (2mb).
    'Every call enlarges it with 2 mb as well. The size of an array in memory does not impact the speed
    'of writing values to it as long as it stays in RAM. When the array becomes larger then available RAM,
    'values are written to disk memory, which is time consuming.
    currentArraySizes = currentArraySizes + enlargementstep
    If currentArraySizes = enlargementstep Then 'at start/initalisation or when timer is reset
        'erases values in arrays
        ReDim arrStamp(1 To currentArraySizes)
        ReDim arrStampID(1 To currentArraySizes)
    Else
        'keeps values in arrays
        ReDim Preserve arrStamp(1 To currentArraySizes)
        ReDim Preserve arrStampID(1 To currentArraySizes)
    End If
End Sub

Private Sub ReportArg(Optional ByVal boExtendedReport As Boolean = False, _
                      Optional ByVal boTransposeReport As Boolean = False, _
                      Optional ByVal OutputToRange As Range = Nothing, _
                      Optional ByVal boForceMillis As Boolean = False, _
                      Optional ByVal boForceNanos As Boolean = False)
    
    'dont generate report if it was generated less then 1 seconds ago (f.e. when ReportCustom
    'was called at end of code, then ignore print call from Class_Terminate)
    Dim stamp_ReportStart As Currency
    QueryPerformanceCounter stamp_ReportStart
    If stamp_ReportEnd > 0 Then If ticsToSeconds(stampsToTics(stamp_ReportEnd, stamp_ReportStart)) <= 1 Then Exit Sub
    
    'Nothing to report when only .Start (1 stamp) was called
    If stampCount < 2 Then GoTo theEnd
    
    'Start report with dimensions
    Dim i As Long 'index number at various places
    Dim v As Variant 'used in various loops over dictionary/collections
    
    Dim arTicDiffs() As Currency 'array to hold the differences between two stamps, same sized array as arrStamp and arrStampID
    Dim dID_colTicDiffs As Object 'key = IDnr, value = collection of time recordings (tics) per IDnr
    Dim key_idnr As Variant 'used to loop through dID_colTicDiffs
    Dim colTicDiffs As New Collection 'collection of TicDiffs coming out of dID_colTicDiffs
    Dim col_item As Variant 'used to loop through tic(difss) in colTicDiffs
    
    Dim cntTic As Double 'tic-values for report
    Dim sumTics As Double
    Dim minTic As Double
    Dim maxTic As Double
    Dim avrTics As Double
    Dim cntAllTics As Double
    Dim sumAllTics As Double
    Dim ticsOverhead As Double
    
    Dim dAll As Object 'temp to hold the values of the output report. key = IDnr concatenated with the ValueType
    Set dAll = CreateObject("scripting.dictionary")
    Dim dHeaders As Object 'dict to filter out unique ValueTypes out of dAll
    Set dHeaders = CreateObject("scripting.dictionary")
    
    Dim header As Variant 'loop through keys in dHeaders
    Dim arrReport() As Variant 'holds report values as (2D) table
    Dim col As Long, row As Long 'index numbers used for looping in arrReport
    Dim strID As String 'IDnr of stamp as string
    
    
    'calculate tic-differences (TicDiffs) per Track-call and store in evenly sized array
    ReDim arTicDiffs(LBound(arrStamp) To stampCount)
    For i = LBound(arrStamp) To stampCount 'LBound always is start-stamp
        arTicDiffs(i) = stampsToTics_fromArrays(i - 1, i)
    Next i
    
    'seperate TicDiffs into ID-specific collection (most time consuming step in this sub)
    Set dID_colTicDiffs = ticsToCollectionsInDictionaryPerID(arTicDiffs, LBound(arTicDiffs))
    
    'filter out any unwanted output here
    dID_colTicDiffs.Remove TrackID.id_start & "" 'start tic value is always 0, so always filter out
    If Not boExtendedReport Then
        If dID_colTicDiffs.Exists(TrackID.id_continue & "") Then dID_colTicDiffs.Remove TrackID.id_continue & ""
        If dID_colTicDiffs.Exists(TrackID.id_pause & "") Then dID_colTicDiffs.Remove TrackID.id_pause & ""
        If dID_colTicDiffs.Exists(TrackID.id_resizingarray & "") Then dID_colTicDiffs.Remove TrackID.id_resizingarray & ""
    End If
    'example of filtering your own defined tracks, both steps required:
    'dID_colTicDiffs.Remove dicStampName_ID("Initialisation")
    'dicStampName_ID.Remove "Initialisation"
    
    'check if TrackByName method is used and store names
    'If TrackByName is not used, name-column won't be printed, so print Totals-name in IDnr column
    If dicStampName_ID.Count > 0 Then
        For Each v In dicStampName_ID.Keys()
            dAll.Item(dicStampName_ID(v) & "_Name") = v
        Next v
        dAll.Item("TOTAL" & "_Name") = "TOTAL"
    Else
        dAll.Item("TOTAL_IDnr") = "TOTAL"
    End If
    
    'UDT's in VBA can't be stored in a collection/dictionary inside a class module.
    'Instead output values are stored in a dictionary with the key being the "id" concatenated with the "_Valuetype".
    'After this the "_Valuetype" becomes the header-name of the output table.
    'This way the output only has to be added/adjusted at one place, instead of at calculation ánd report-output functions.
    'Other options, like ADO recordset or an array of UDT's, would require to adjust the reportcode in 3 places:
    'at decleration of the UDT, at calculation (sum, count, etc) and at report formatting/creating the table.
    'In current set up, these three things are done at the same place.
    
    ' -------------------------------------------------------------------------
    ' ----------------------- Start calculating report ------------------------
    ' -------------------------------------------------------------------------
    
    cntAllTics = 0: sumAllTics = 0
    For Each key_idnr In dID_colTicDiffs.Keys 'loop all identical IDnrs
        
        dAll.Item(key_idnr & "_IDnr") = key_idnr
        
        'overwrite names of the TrackID's this class uses.
        Select Case key_idnr
            Case TrackID.id_start: dAll.Item(TrackID.id_start & "_Name") = "(Start)" 'Initialisation
            Case TrackID.id_pause: dAll.Item(TrackID.id_pause & "_Name") = "(Before Pause)" 'Pause start
            Case TrackID.id_continue: dAll.Item(TrackID.id_continue & "_Name") = "(Continue)" 'After Pause/Paused
            Case TrackID.id_resizingarray: dAll.Item(TrackID.id_resizingarray & "_Name") = "(Resizing)" 'Resizing arStampID and arStamp
        End Select
        
        Set colTicDiffs = dID_colTicDiffs(key_idnr)
        cntTic = 0: minTic = 1E+15: maxTic = 0: sumTics = 0: avrTics = 0
        'break here to see the cpu tic-differences in between TrackBy calls
        For Each col_item In colTicDiffs 'col_item = collection of (ammount of) tics
            cntTic = cntTic + 1
            minTic = Min(minTic, col_item)
            maxTic = Max(maxTic, col_item)
            sumTics = sumTics + col_item
        Next col_item
        sumAllTics = sumAllTics + sumTics
        cntAllTics = cntAllTics + cntTic
        
        v = key_idnr 'IDnr
        dAll.Add v & "_Count", FormatNumber(cntTic, 0)
        dAll.Add v & "_Sum of tics", FormatNumber(sumTics, 0)
        dAll.Add v & "_Percentage", "" 'value cant be calculated yet as total sum is yet unknown, but already place in output table
        dAll.Add v & "_Time sum", secondsProperString(ticsToSeconds(sumTics), boForceMillis, boForceNanos)
        
        If Not boExtendedReport Then GoTo nextV_SkipExtendedOutput
        ' ---------------------- Output for extended report: ----------------------
        
        dAll.Add v & "_Minimum", minTic
        dAll.Add v & "_Maximum", maxTic
        dAll.Add v & "_Average", FormatNumber(sumTics / cntTic)
        dAll.Add v & "_Median", FormatNumber(MedianOfFirst_x_Elements(colTicDiffs, 1000)) 'Only from first 1000 tic measurements
        
        'overhead
        'Standard TrackID's (fe id_pause) test to False here as there isnt a string name in
        'dicStampName_ID for them (even though they are already added to dAll with a name).
        If dicStampName_ID.Exists(dAll(v & "_Name")) Then 'if TrackByName used
            ticsOverhead = OverheadPerTrackCall(v, "ByNameMin")
            dAll.Add v & "_Overhead Min", FormatNumber(ticsOverhead, 0)
            dAll.Add v & "_Overhead Avr", FormatNumber(OverheadPerTrackCall(dAll(v & "_Name"), "ByNameAvr"))
        Else
            ticsOverhead = OverheadPerTrackCall(v, "ByIDMin")
            dAll.Add v & "_Overhead Min", FormatNumber(ticsOverhead, 0)
            dAll.Add v & "_Overhead Avr", FormatNumber(OverheadPerTrackCall(v, "ByIDAvr"))
        End If
        
        'corrected values
        dAll.Add v & "_Sum (cor)", FormatNumber(sumTics - (ticsOverhead * cntTic), 0)
        If cntTic > 1 Then
            dAll.Add v & "_Avr (cor)", FormatNumber(sumTics / cntTic - ticsOverhead, 2)
            dAll.Add v & "_Min (cor)", FormatNumber(minTic - ticsOverhead, 0)
            dAll.Add v & "_Max (cor)", FormatNumber(maxTic - ticsOverhead, 0)
        End If
        
        'time values
        dAll.Add v & "_Time avr", secondsProperString(ticsToSeconds(avrTics - ticsOverhead * 0), boForceMillis, boForceNanos)
nextV_SkipExtendedOutput:
    Next key_idnr
    
    'restores statically stored stamp arrays, does nothing if not called before
    v = OverheadPerTrackCall(v, "restore")
    
    'calculate percentage per ID, now that sumAllTics is known
    For Each key_idnr In dID_colTicDiffs.Keys 'all identical IDnrs
        v = key_idnr
        dAll.Item(v & "_Percentage") = FormatPercent(dAll.Item(v & "_Sum of tics") / sumAllTics)
    Next key_idnr
    
    'calculate totals
    dAll.Item("TOTAL" & "_Count") = FormatNumber(cntAllTics, 0)
    dAll.Item("TOTAL" & "_Sum of tics") = FormatNumber(sumAllTics, 0)
    If sumAllTics > 0 Then dAll.Item("TOTAL" & "_Percentage") = FormatPercent(dAll.Item("TOTAL" & "_Sum of tics") / sumAllTics)
    dAll.Item("TOTAL" & "_Time sum") = secondsProperString(ticsToSeconds(sumAllTics), boForceMillis, boForceNanos)
    
    If boExtendedReport Then
        If cntAllTics > 0 Then dAll.Item("TOTAL" & "_Average") = Round(sumAllTics / cntAllTics, 0)
    End If
    
    'dAll now holds all the values for the report. key = IDnr_ValueType, value = value
    
    ' -------------------------------------------------------------------------
    ' ---------------------- End of calculating report ------------------------
    ' -------------------------------------------------------------------------
    
    'add unique headers for output table
    dHeaders.Add "IDnr", 1 'makes sure IDnr is first/most left column
    For Each v In dAll.Keys
        dHeaders.Item(RIGHT_AfterLastCharsOf(v, "_")) = 0
    Next v
    
    col = 0: row = 0 'column, row
    ReDim arrReport(1 To dHeaders.Count, 1 To dID_colTicDiffs.Count + 1 + 1) 'arrReport(headers, datarows + headerrow + totalsrow)
    'loop all possible ID numbers and store values of dAll in arrReport
    'Byte range is 0-255, minimum ID = 0, nr -1 for headers, nr 256 for TOTAL, sorted order (id_pause etc as last)
    For i = -1 To 256
        Select Case i
            Case -1: 'headers
            Case 256: strID = "TOTAL"
            Case Else
                strID = i & ""
                If Not dID_colTicDiffs.Exists(strID) Then GoTo nextI
        End Select
        row = row + 1
        col = 0
        
        For Each header In dHeaders.Keys()
            col = col + 1
            If row = 1 Then
                arrReport(col, row) = header
            Else
                If dAll.Exists(strID & "_" & header) Then
                    arrReport(col, row) = dAll.Item(strID & "_" & header)
                End If
            End If
        Next header
nextI:
    Next i
    
    If boTransposeReport Then arrReport = Transpose2DArray(arrReport)
    
    Array2DToImmediate (arrReport)
    
theEnd:
    QueryPerformanceCounter stamp_ReportEnd
    Debug.Print "Total time recorded: " & secondsProperString(ticsToSeconds(stampsToTics_fromArrays(LBound(arrStamp), stampCount)))
    If boExtendedReport Then Debug.Print "Time to calculate report stamps: " & secondsProperString(ticsToSeconds(stampsToTics(stamp_ReportStart, stamp_ReportEnd)))
    If boExtendedReport Then Debug.Print "Max precision: " & secondsProperString(Precision, , True)
    Debug.Print ""
    
End Sub

' ============================================= '
' Private Functions - Specific Report Helpers
' ============================================= '
' @OverheadPerTrackCall                 - overhead of QPC including TrackBy-methods
' @OverheadPerQPCcall                   - overhead of only the QPC function
' @Precision                            - returns maximum precision of this class in seconds
' @ticsToCollectionsInDictionaryPerID   - group stamps from global stamparray into seperate (per tracked ID) collections
' @stampsToTics_fromArrays              - retrieve tics from arrays and return difference
' @stampsToTics                         - returns difference between to stamps
' @ticsToSeconds                        - convert qpc-tics to seconds
' @secondsProperString                  - convert seconds to appropriate readable text

Private Function OverheadPerTrackCall(NameOrID As Variant, Action As String) As Double
    'calculates the overhead in amount of tics to call methods TrackByTheID and TrackByName.
    'As these two methods adjust (values in) global variables, these global variables
    'are also used to calculate the overhead. They are first copied and stored as Static, which
    'prevents the stamp-arrays from being copied every time an ID or Name is tested.
    
    Dim frst_loop As Long: frst_loop = 1
    Dim last_loop As Long: last_loop = frst_loop + Max(overheadTestCount, 1)
    
    'create global arrays only once/statically and keep them in memory in between calls
    'Static to keep them alive in between function calls/as long as code is running.
    Static stampCountTemp As Long
    Static arrStampTemp() As Currency
    Static arrStampIDTemp() As Byte
    
    'copy global variables to temps only once
    If stampCountTemp = 0 Then 'only 0 when initialized
        stampCountTemp = stampCount
        arrStampTemp = arrStamp
        arrStampIDTemp = arrStampID
    End If
    
    stampCount = 0
    
    Dim i As Long, id As Byte, name As String
    Select Case Action
        Case "ByIDAvr", "ByIDMin"
            id = CByte(NameOrID)
            For i = frst_loop To last_loop
                TrackByTheID id
            Next i
            
        Case "ByNameAvr", "ByNameMin"
            name = NameOrID
            For i = frst_loop To last_loop
                TrackByName name
            Next i
            
        Case Else '"restore"
            
    End Select
    
    Select Case Action
        Case "ByIDAvr", "ByNameAvr" 'average
            OverheadPerTrackCall = (arrStamp(last_loop) - arrStamp(frst_loop)) * fromCurr / last_loop
            Exit Function
            
        Case "ByIDMin", "ByNameMin" 'minimum
            Dim minval As Double
            minval = 1E+15
            For i = frst_loop To last_loop - 1
                minval = Min(minval, CDbl((arrStamp(i + 1) - arrStamp(i)) * fromCurr))
            Next i
            OverheadPerTrackCall = minval
            Exit Function
            
        Case Else '"restore"
            If stampCountTemp = 0 Then 'check if OverheadPerTrackCall was used before (could be if not boExtendedReport)
                OverheadPerTrackCall = 0
                Exit Function
            End If
            'restore global variables, erase static ones
            stampCount = stampCountTemp
            arrStamp = arrStampTemp
            arrStampID = arrStampIDTemp
            stampCountTemp = 0
            ReDim arrStampTemp(0) 'erase/free memory
            ReDim arrStampIDTemp(0)
            OverheadPerTrackCall = OverheadPerQPCcall
            Exit Function
            
    End Select
    
End Function

Private Function OverheadPerQPCcall() As Double
    'calculates (average) time it takes to call QPC function directly.
    'Does not include overhead of TrackByTheID (calling the function
    'itself and the if-block within) or TrackByName (the time it takes
    'to look up the IDnr from dictionary).
    
    Dim arr() As Currency: ReDim arr(1 To overheadTestCount)
    Dim i As Long
    
    For i = LBound(arr) To UBound(arr)
        QueryPerformanceCounter arr(i)
    Next i
    OverheadPerQPCcall = (arr(UBound(arr)) - arr(LBound(arr))) * fromCurr / overheadTestCount
End Function
Private Function Precision() As Double
    'returns maximum available precision of this benchmark class on the machine it runs in (full) seconds.
    'As described in microsoft docs https://docs.microsoft.com/en-us/windows/win32/sysinfo/acquiring-high-resolution-time-stamps#low-level-hardware-clock-characteristics
    
    'Tick Interval = 1/(Performance Frequency) = Resolution
    Dim resolution As Double
    resolution = 1 / freq
    
    'ElapsedTime = Ticks * Tick Interval = AccessTime
    Dim accesTime As Double
    accesTime = OverheadPerQPCcall * resolution
    
    Precision = Max(resolution, accesTime)
    
End Function

Private Function ticsToCollectionsInDictionaryPerID(ByRef arTdifs() As Currency, ByVal lb As Long) As Object
    'Groups the global stamp-array into seperate collections per ID
    'Returns a dictionary where key = TrackID, value = collection of tics
    'example result in jsonformat: {"255":[0],"1":[156],"2":[675,766,523,764,651]}
    
    Set ticsToCollectionsInDictionaryPerID = CreateObject("scripting.dictionary")
    
    Dim offset As Long
    For offset = 0 To stampCount - 1
        On Error GoTo new_item
        ticsToCollectionsInDictionaryPerID.Item(LTrim$(str$(arrStampID(lb + offset)))).Add arTdifs(lb + offset)
        On Error GoTo 0
    Next
    
    Exit Function
    
new_item:
    Set ticsToCollectionsInDictionaryPerID.Item(LTrim$(str$(arrStampID(lb + offset)))) = New Collection
    Resume
End Function

Private Function stampsToTics_fromArrays(ByVal stampNrBefore As Long, ByVal stampNrAfter As Long) As Currency
    'Gets stamps from arrays and return difference in tics between them
    If stampNrBefore < LBound(arrStamp) Then
        stampsToTics_fromArrays = 0
    Else
        stampsToTics_fromArrays = stampsToTics(arrStamp(stampNrBefore), arrStamp(stampNrAfter))
    End If
End Function

Private Function stampsToTics(ByVal stampBefore As Currency, ByVal stampAfter As Currency) As Currency
    'Calculates the difference in between two QPC stamps and upscales them from Currency to whole numbers
    
    'example returns of QPC:
    '- as Currency -> 304462680,3775    --> needs upscaling by 10 000
    '- as LongLong -> 3044626803775
    '--->
    '- as Currency -> (QPC2 - QPC1) * 10000
    '- as LongLong -> (QPC2 - QPC1)
    
    'example returns of QPF (is system specific, but commonly 10Mhz on Windows 10)
    'with a usual QPF on windows 10 (10MHz):
    '- as Currency ->     1000  =      1 000
    '- as LongLong -> 10000000  = 10 000 000
    
    '---> if freq is 10MHz then:
    '---> 10 million tics per second
    '   1 tic = (1 / 10 000 000) seconds
    '   1 tic = 0.0000001 seconds
    '   1 tic = 0.0001 milliseconds
    '   1 tic = 0.1 microseconds
    '   1 tic = 100 nanoseconds
    
    'tics t to seconds s = t/(s * 1)
    'tics to milliseconds = t/(s * 1e3)
    'tics to microseconds = t/(s * 1e6)
    'tics to nanoseconds = t/(s * 1e9)
    
    stampsToTics = (stampAfter - stampBefore) * fromCurr
End Function
Private Function ticsToSeconds(ByVal tics As Currency) As Double
    'returns time in full seconds
    If Int(tics) <> tics Or Int(freq) <> freq Then Err.Raise 9999999, , "QPC or QPF returns with datatype As Currency downscales the returns with 10 000. Upscale both returns before calling this funciton."
    'Int(freq) is actually not a proper check to see if it has been upscaled, as it is often also a round number when downscaled (10mhz)
    ticsToSeconds = tics / freq
End Function
Private Function secondsProperString(ByVal t As Double, _
                                     Optional ByVal boForceMilliSeconds As Boolean = False, _
                                     Optional ByVal boForceNanoSeconds As Boolean = False) As String
    If boForceNanoSeconds Then boForceMilliSeconds = False
    Dim res As String
    
    If t >= 3599 And Not boForceMilliSeconds And Not boForceNanoSeconds Then 'more then 1 hour
        res = VBA.Format$(t / 3600 / 24, "HH:mm:ss")
        
    ElseIf t > 599 And Not boForceNanoSeconds And Not boForceMilliSeconds Then 'more then 10 minutes
        res = VBA.Format$(t / 3600 / 24, "mm:ss")
        
    ElseIf t > 120 And Not boForceNanoSeconds And Not boForceMilliSeconds Then '>2 minutes
        res = Round(t, 1) & " s"
        
    ElseIf t > 10 And Not boForceNanoSeconds And Not boForceMilliSeconds Then '>10 seconds
        res = Round(t, 1) & " s"
        
    ElseIf t > 0.9 And Not boForceNanoSeconds And Not boForceMilliSeconds Then '>0.9 second
        res = Round(t, 2) & " s"
        
    ElseIf t > (10 / 1000#) And Not boForceNanoSeconds Or boForceMilliSeconds Then 'millisecond (1 ms = 10-E3 s)
        res = Round(t * 1000#, IIf(boForceMilliSeconds, 2, 0)) & " ms"
        
    ElseIf t > (1 / 1000#) And Not boForceNanoSeconds Then 'millisecond (1 ms = 10-E3 s)
        res = Round(t * 1000#, 2) & " ms"
        
    ElseIf t > (10 / 1000000#) And Not boForceNanoSeconds Then 'microsecond (1 us = 10-E6 s)
        res = Round(t * 1000000#) & " us"
        
    ElseIf t > (10 / 1000000000#) Or boForceNanoSeconds Then 'nanosecond (1 ns = 10-E9 s)
        res = Round(t * 1000000000#) & " ns"
        
        'Any value below this is probably below the maximum precision of the QPC function (and likely cause of overhead correction).
        'max precision = 1 / frequency * QPC overhead.
        
    ElseIf t > (10 / 1000000000000#) Then res = Round(t * 1000000000000#) & " ps" 'picosecond (1 ps = 10-E12 s)
    ElseIf t > (10 / 1E+15) Then res = Round(t * 1E+15) & " fs" 'femtosecond (1 fs = 10-E15 s)
    ElseIf t > (10 / 1E+18) Then res = Round(t * 1E+18) & " as" 'attosecond (1 as = 10-E18 s)
    ElseIf t > (10 / 1E+21) Then res = Round(t * 1E+21) & " zs" 'zeptosecond (1 zs = 10-E21 s) -> shortest time ever measured was 247 zeptoseconds :)
    ElseIf t > (10 / 1E+24) Then res = Round(t * 1E+24) & " ys" 'yoctosecond (1 ys = 10-E24 s)
        '"For Decimal expressions, any fractional value less than 1E-28 might be lost." (.net docs)
        
    ElseIf t < 0 Then
        res = "<0"
        'happens when overhead correction is larger then actual tics passed (to lower this chance use minimum overhead instead of average).
        'output extended report to see corrected timevalues
    ElseIf t = 0 Then
        res = "0"
        'should only happen with trackid.id_start
    Else
        res = "-?-"
        'really fast pc or just err?
        Debug.Assert False
    End If
    secondsProperString = res
End Function

' ============================================= '
' Private Functions - General Report Helpers
' ============================================= '
' @Min                          - minimum of two double-values
' @Max                          - maximum of two double-values
' @MedianOfFirst_x_Elements     - median of a part of a collection
' @QuickSortArray               - quick sort an array
' @RIGHT_AfterLastCharsOf       - last part of string
' @Array2DToImmediate           - print array to console
' @Transpose2DArray             - flip 2D-array 90 degrees

Private Function Min(ByVal x As Double, ByVal y As Double) As Double
    If x < y Then Min = x Else Min = y
End Function
Private Function Max(ByVal x As Double, ByVal y As Double) As Double
    If x > y Then Max = x Else Max = y
End Function

Private Function MedianOfFirst_x_Elements(col As Collection, x As Long) As Double 'MedianFromCollection
    'puts specified amount (x) of values of collection into an array, quicksorts
    'the array and then takes out the Median value.
    Dim c As Long: c = IIf(x > col.Count, col.Count, x) 'sorting large collection is time consuming so take minimum
    Dim ar() As Variant
    ReDim ar(1 To c)
    Dim i As Long
    For i = 1 To c 'col.count
        ar(i) = col(i)
    Next i
    QuickSortArray ar, LBound(ar), UBound(ar)
    MedianOfFirst_x_Elements = ar((LBound(ar) + UBound(ar)) \ 2) 'backslash rounds nr
End Function
Private Function QuickSortArray(ByRef vArray As Variant, inLow As Long, inHi As Long) 'recursive
    'https://stackoverflow.com/a/152325/6544310
    Dim pivot As Variant
    Dim tmpSwap As Variant
    Dim tmpLow As Long
    Dim tmpHi As Long
    
    tmpLow = inLow
    tmpHi = inHi
    
    pivot = vArray((inLow + inHi) \ 2)
    
    While (tmpLow <= tmpHi)
        While (vArray(tmpLow) < pivot And tmpLow < inHi)
            tmpLow = tmpLow + 1
        Wend
        
        While (pivot < vArray(tmpHi) And tmpHi > inLow)
            tmpHi = tmpHi - 1
        Wend
        
        If (tmpLow <= tmpHi) Then
            tmpSwap = vArray(tmpLow)
            vArray(tmpLow) = vArray(tmpHi)
            vArray(tmpHi) = tmpSwap
            tmpLow = tmpLow + 1
            tmpHi = tmpHi - 1
        End If
    Wend
    
    If (inLow < tmpHi) Then QuickSortArray vArray, inLow, tmpHi
    If (tmpLow < inHi) Then QuickSortArray vArray, tmpLow, inHi
End Function

Private Function RIGHT_AfterLastCharsOf(ByVal strLeft As String, ByVal chars As String) As String
    'returns the part of the string that is most right to given char(s)
    Dim s() As String
    s = Split(strLeft, chars, -1, vbBinaryCompare)
    RIGHT_AfterLastCharsOf = s(UBound(s))
End Function


Private Sub Array2DToImmediate(ByVal arr As Variant)
    'Prints a 2D-array of values to a table (with same sized column widhts) in the immmediate window
    
    'Each character in the Immediate window of VB Editor (CTRL+G to show) has the same pixel width,
    'thus giving the option to output a proper looking 2D-array (a table with variable string lenghts).
    
    'settings
    Dim spaces_between_collumns As Long: spaces_between_collumns = 2
    Dim NrOfColsToOutlineLeft As Long: NrOfColsToOutlineLeft = 2 'all cols are outlined right, except for first x (2 here, so IDnr and Name)
    Dim maxLength As Long: maxLength = 198 * 1021& 'capacity of Immediate window is about 200 lines of 1021 characters per line.
    Dim i As Long, j As Long
    Dim arrMaxLenPerCol() As Long
    Dim str As String
    
    'determine max stringlength per column
    ReDim arrMaxLenPerCol(UBound(arr, 1))
    For i = LBound(arr, 1) To UBound(arr, 1)
        For j = LBound(arr, 2) To UBound(arr, 2)
            arrMaxLenPerCol(i) = IIf(Len(arr(i, j)) > arrMaxLenPerCol(i), Len(arr(i, j)), arrMaxLenPerCol(i))
        Next j
    Next i
    
    'build table
    For j = LBound(arr, 2) To UBound(arr, 2)
        For i = LBound(arr, 1) To UBound(arr, 1)
            'outline left --> value & spaces & column_spaces
            If i < NrOfColsToOutlineLeft Then
                On Error Resume Next
                str = str & arr(i, j) & Space$((arrMaxLenPerCol(i) - Len(arr(i, j)) + spaces_between_collumns) * 1)
                
                'last column to outline left --> value & spaces
            ElseIf i = NrOfColsToOutlineLeft Then
                On Error Resume Next
                str = str & arr(i, j) & Space$((arrMaxLenPerCol(i) - Len(arr(i, j))) * 1)
                
                'outline right --> spaces & column_spaces & value
            Else 'i > NrOfColsToOutlineLeft Then
                On Error Resume Next
                str = str & Space$((arrMaxLenPerCol(i) - Len(arr(i, j)) + spaces_between_collumns) * 1) & arr(i, j)
            End If
        Next i
        str = str & vbNewLine
        If Len(str) > maxLength Then GoTo theEnd
    Next j
    
theEnd:
    'capacity of Immediate window is about 200 lines of 1021 characters per line.
    If Len(str) > maxLength Then str = Left(str, maxLength) & vbNewLine & " - Table to large for Immediate window"
    Debug.Print str
End Sub

Private Function Transpose2DArray(arr() As Variant) As Variant()
    Dim arTemp() As Variant
    Dim c As Long
    Dim r As Long
    ReDim arTemp(LBound(arr, 2) To UBound(arr, 2), LBound(arr, 1) To UBound(arr, 1))
    For r = LBound(arTemp, 1) To UBound(arTemp, 1)
        For c = LBound(arTemp, 2) To UBound(arTemp, 2)
            arTemp(r, c) = arr(c, r)
        Next c
    Next r
    Transpose2DArray = arTemp
End Function

 

[patricktoulon]

après si je regarde simplement ta macro

Sub Tirages()
Dim TDon(), TNoms() As String, TRésu(), M As Long, L As Integer, c As Integer, LMax As Long, MMax As Long, j As Long, Wsh As Worksheet
Dim bm As New cBenchmark
bm.Start
ImageRoueTourne
' Récupération des inscrits
TDon = WshT1.[A3:B3].Resize(WshT1.Cells(2 ^ 20, "A").End(xlUp).row - 2).Value
ReDim TNoms(1 To UBound(TDon))
For L = 1 To UBound(TNoms)
TNoms(TDon(L, 1)) = TDon(L, 2)
Next L
' Tirage
If Tirage1vs1OK(NbJrs:=UBound(TNoms), Manches:=2) Then
Rem. ——— Versement du tableau Tirage vers un tableau de valeurs de cellules.
MMax = UBound(Tirage, 1) ' Nombre de tours
LMax = UBound(Tirage, 2) ' Nombre de lignes de rencontres.
ReDim TRésu(1 To LMax * 2, 1 To 2)
For M = 1 To MMax
For L = 1 To LMax
For c = 1 To 2
j = Tirage(M, L, c)
If j <> 0 Then
TRésu(2 * (L - 1) + c, 1) = j: TRésu(2 * (L - 1) + c, 2) = TNoms(j)
Else
TRésu(2 * (L - 1) + c, 1) = Empty: TRésu(2 * (L - 1) + c, 2) = Empty
End If:
Next c
Next L
Set Wsh = Worksheets(M)
Wsh.[A3].Resize(UBound(TRésu, 1), 2).Value = TRésu
Next M
End If
bm.TrackByName "fin du melange"
'on place le msgbox avant l'affichage du userform pour ne pas compter celui ci et que le message s'affiche juste avant et non bloquant (pour afficher les deux

ImageRoueFixe
End Sub

alors que j'en fait qu'une sur un tableau 2 dim de 40 lignes sur 1 colonne soit 40 items
même si on ne faisait rien dans ces boucles tu peux pas faire 200 µf et moi 25ms(en une seule boucle sur 40 items )voyons
à un moment il faut être réaliste

 

[Dranreb]

Les traitements de récupération des inscrits ni les mises en forme du résultat ne sont chronométrées. Seule la Tirage1vs1OK l'est. C'est elle qui pourrait avoir du fil à retordre et prendre un temps fou s'il y avait trop peu de joueurs pour trop de manches ou des contraintes supplémentaires de rencontres interdites.

 

[patricktoulon]

oui je suis d'accords mais les boucles tu les fait non?
au moins deux dans la Tirage1vs1OK en plus d'appeler la DescConfig du userform, tu appelle deux fonctions associées
donc au total on est sur 3 boucle minimum entre la sub tirages et la Tirage1vs1OK

comment veux tu faire 200µf c'est tout bonnement pas réaliste
je te le dit soit il y a une erreur de virgule soit tu pointe pas les bons moments
tu n'es
pas realiste
c'est gros comme le nez sur la figure

si je prends plus de temps dessus je suis sur que je vais trouver l'erreur

 

[Dranreb]

L’invocation de Tirage1vs1OK n'est pas dans une boucle. Je ne comprends pas ce que tu veux dire.