Sub Estadist()
'@dj.vivanco'
Dim dicJoin As Object, dicRes As Object
Dim K As Variant, hjResultado As Worksheet
Set hjResultado = Sheets("RESULTADO")
Set dicJoin = CreateObject("Scripting.Dictionary") Set dicRes = CreateObject("Scripting.Dictionary")
hjResultado.Range("C4:Z50").ClearContents hjResultado.Range("C4:Z50").Interior.Color = RGB(255, 255, 255)
cantJugadores = Range("A" & Rows.Count).End(xlUp).Row - 2 cantDias = Cells(Columns.Count).End(xlToLeft).Column
grupo = 1
dia = 1
y = 0
For cantJug = cantJugadores To 2 Step -1
For SUBGRUPO = 1 To cantJugadores - 1
a = 1
For x = 1 To SUBGRUPO
For COL = 1 To cantDias
'concatenar:'
junto = ""
For fila = 1 To cantJugadores - y
junto = junto & " " & Trim(Cells(fila + x, COL).value)
Next fila
junto = a & junto
'Comparo si existe uno igual'
If Not dicJoin.exists(junto) Then
dicJoin.Add junto, COL
Else: 'existe'
primerdia = dicJoin(junto)
If Not dicRes.exists(primerdia & x) Then dicRes.Add primerdia & x, primerdia & " " & junto
dicRes.Add COL & x, primerdia & " " & junto
existeGrupo = True
End If
Next COL
dicJoin.RemoveAll
a = a + 1
Next x
'
If existeGrupo = True Then
'Escribe datos encontrados y termina'
COL = 3
item = 0
Set dicOrden = SortDictionaryByValue(dicRes)
For Each K In dicOrden.Keys()
'dia como titulo'
dia = Left(K, Len(K) - 1)
hjResultado.Cells(4, COL).value = "Día " & dia
'posicion'
nombre = Split(dicOrden.Items()(item), " ")
pos = nombre(1)
grupo = CInt(nombre(0))
If grupo <> gr Then
miRNDr = 20 + 200 * Rnd()
miRNDg = 20 + 200 * Rnd()
miRNDb = 20 + 200 * Rnd()
miRNDx = Array(miRNDr, miRNDg, miRNDb)
cRGB = RGB(10 + miRNDx(0), 10 + miRNDx(1), 10 + miRNDx(2))
'
End If
For x = 2 To UBound(nombre)
hjResultado.Cells(pos + 4, COL).value = nombre(x)
hjResultado.Cells(pos + 4, COL).Interior.Color = cRGB
pos = pos + 1
Next x
gr = grupo
item = item + 1
COL = COL + 1
Next K
Sheets("RESULTADO").Select Exit Sub
End If
y = y + 1
Next SUBGRUPO
Next cantJug
Sheets("RESULTADO").Select
End Sub
Public Function SortDictionaryByValue(dict As Object, Optional sortorder As XlSortOrder = xlAscending) As Object
On Error GoTo eh
Dim arrayList As Object
Set arrayList = CreateObject("System.Collections.ArrayList")
Dim dictTemp As Object
Set dictTemp = CreateObject("Scripting.Dictionary")
' Put values in ArrayList and sort'
' Store values in tempDict with their keys as a collection'
Dim key As Variant, value As Variant, coll As Collection
For Each key In dict
value = dict(key)
' if the value doesn't exist in dict then add'
If dictTemp.exists(value) = False Then
' create collection to hold keys'
' - needed for duplicate values'
Set coll = New Collection
dictTemp.Add value, coll
' Add the value'
arrayList.Add value
End If
' Add the current key to the collection'
dictTemp(value).Add key
Next key
' Sort the value'
arrayList.Sort
' Reverse if descending'
If sortorder = xlDescending Then
arrayList.Reverse
End If
dict.RemoveAll
' Read through the ArrayList and add the values and corresponding'
' keys from the dictTemp'
Dim item As Variant
For Each value In arrayList
Set coll = dictTemp(value)
For Each item In coll
dict.Add item, value
Next item
Next value
Set arrayList = Nothing
' Return the new dictionary'
Set SortDictionaryByValue = dict
Done:
Exit Function
eh:
If Err.Number = 450 Then
Err.Raise vbObjectError + 100, "SortDictionaryByValue" _
, "Cannot sort the dictionary if the value is an object"
End If
End Function
