Excel - Macro para comparar masivamente

 
Vista:
sin imagen de perfil
Val: 31
Ha disminuido su posición en 2 puestos en Excel (en relación al último mes)
Gráfica de Excel

Macro para comparar masivamente

Publicado por Sergio (10 intervenciones) el 10/10/2020 21:18:57
Buenas.llevo días dandole vueltas a esto y no logro resolverlo.
He hecho un ejemplo corto para aclararme mejor. Pongamos que son 3 amigos que juegan 5 partidas al poker cada día durante 7 dias.
Cada columna es un día y cada celda de la columna refleja el ganador de cada partida.
Quiero una macro que me compare todos los días con todos y me diga cuál es el máximo de coincidencias, cuántos días coincide y cuáles son esos dias (está descrito en la plantilla también). Los fondos verdes que he colocado en la plantilla son los que me gustaría que me devolviera la macro.

A ver si a alguien se le ocurre algo.

Gracias
Valora esta pregunta
Me gusta: Está pregunta es útil y esta claraNo me gusta: Está pregunta no esta clara o no es útil
0
Responder
Imágen de perfil de David
Val: 145
Ha mantenido su posición en Excel (en relación al último mes)
Gráfica de Excel

Macro para comparar masivamente

Publicado por David (29 intervenciones) el 10/10/2020 22:26:59
No me queda muy claro, a que te refieres con "coincidencias". Es un ranking o si se repiten los ganadores y el numero que ganaron por día?
Adjunto imagen con otras dudas.

Screenshot_2
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar
sin imagen de perfil
Val: 31
Ha disminuido su posición en 2 puestos en Excel (en relación al último mes)
Gráfica de Excel

Macro para comparar masivamente

Publicado por Sergio (10 intervenciones) el 10/10/2020 23:16:10
Lo que busco es llamémoslo "un orden recurrente". O sea que coincida el mayor número de ganadores en el mayor número de días posibles. En el ejemplo, la partidas 2,3 y 4 las ganan Pedro Mario y Mario y eso se cumple 2 dias de 7 si esto en vez de 7 días fueran 100 podría ver cuál es ese "orden recurrente" los otros días al solo coincidir 2 la macro los descartaría. No sé si me he explicado mucho.

Gracias por responder tan rápido
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar
Imágen de perfil de David
Val: 145
Ha mantenido su posición en Excel (en relación al último mes)
Gráfica de Excel

Macro para comparar masivamente

Publicado por David (29 intervenciones) el 10/10/2020 23:33:31
Creo que entiendo, es una secuencia en posición de las veces ganadas.
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar
sin imagen de perfil
Val: 31
Ha disminuido su posición en 2 puestos en Excel (en relación al último mes)
Gráfica de Excel

Macro para comparar masivamente

Publicado por Sergio (10 intervenciones) el 10/10/2020 23:38:12
Si. En principio sería así.
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
1
Comentar
Imágen de perfil de David
Val: 145
Ha mantenido su posición en Excel (en relación al último mes)
Gráfica de Excel

Macro para comparar masivamente

Publicado por David (29 intervenciones) el 11/10/2020 00:44:19
Lo preparo y te lo envío.
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar
sin imagen de perfil
Val: 31
Ha disminuido su posición en 2 puestos en Excel (en relación al último mes)
Gráfica de Excel

Macro para comparar masivamente

Publicado por Sergio (10 intervenciones) el 11/10/2020 11:47:10
Perfecto.
Mucha gracias
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar
Imágen de perfil de David
Val: 145
Ha mantenido su posición en Excel (en relación al último mes)
Gráfica de Excel

Macro para comparar masivamente

Publicado por David (29 intervenciones) el 12/10/2020 01:55:15
Hola, ya esta casi listo. Una pregunta: Aceptarás 2 o más coincidencias, es decir 2 grupos o mas de coincidencias?
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar
sin imagen de perfil
Val: 31
Ha disminuido su posición en 2 puestos en Excel (en relación al último mes)
Gráfica de Excel

Macro para comparar masivamente

Publicado por Sergio (10 intervenciones) el 12/10/2020 02:31:15
Es algo que me había planteado. Porque en el ejemplo son solo 7 días pero cuando la cifra sea mucho mayor seguro que me puedo encontrar por ejemplo un Mario Mario Pedro que se repita 10 días y un Juan Mario Pedro que lo haga otros 9. Sí que estaría bien tener las frecuencias con más nombres y que los días sean indiferentes en número siempre que sean un porcentaje alto ( o sea que se repitan con cierta frecuencia). Buff no sé si me he explicado bien...jejeje
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
1
Comentar
Imágen de perfil de David
Val: 145
Ha mantenido su posición en Excel (en relación al último mes)
Gráfica de Excel

Macro para comparar masivamente

Publicado por David (29 intervenciones) el 13/10/2020 23:19:54
Por fin terminado. Adjunto el libro, debes habilitar macros de excel y presionar el boton.
No tiene limite de jugadores, ni limite de dias, ni de partidas a jugar.

Me avisas si tienes algun problema.

Pd: No cambies ni insertes filas ni columnas, solo puedes rellenar con datos.




Screenshot_1

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
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
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar
sin imagen de perfil
Val: 31
Ha disminuido su posición en 2 puestos en Excel (en relación al último mes)
Gráfica de Excel

Macro para comparar masivamente

Publicado por Sergio (10 intervenciones) el 13/10/2020 23:34:29
Muchas gracias por la dedicacion...viendo la programación realmente me quedaba demasiado grande.
Pruebo y te digo.

Un saludo y muchas gracias crack
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar
sin imagen de perfil
Val: 31
Ha disminuido su posición en 2 puestos en Excel (en relación al último mes)
Gráfica de Excel

Macro para comparar masivamente

Publicado por Sergio (10 intervenciones) el 14/10/2020 00:02:38
Esta muy bien. Lo he implementado a mi tabla mucho más extensa y funciona a la perfección. Solo hay una cosa que el programa no contempla. Te he modificado la tabla para que sea más claro. Verás que el día 1 y 2 comparten los ganadores de la primera, tercera y quinta partida, pero los descarta como máxima coincidencia, supongo que porque las coincidencias no son seguidas. Crees que eso se puede rectificar para que me lo cuente como algo valido? Te paso el archivo.
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar