Option Explicit
' </> ------------------------------------------------------------------- </>
' </> ---&--- </> TRES COINCIDENCIAS </> ---&--- </>
' </> ------------------------------------------------------------------- </>
Sub Cuenta_3()
Dim Fila As Integer, Tabla(500000) As Integer, Num As Long, Total As Integer, _
Fil As Long, Col As Integer, a As Integer, b As Integer, c As Integer, Ini As Single
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Ini = Timer
Sheets("Hoja1").Select
' ---&--- La tabla de consulta para 3 ACIERTOS
Fila = 5
While Cells(Fila, 3) <> ""
For a = 3 To 6
For b = a + 1 To 7
For c = b + 1 To 8
Num = (Cells(Fila, a) * 10000) + (Cells(Fila, b) * 100) + Cells(Fila, c)
Tabla(Num) = Tabla(Num) + 1
Next
Next
Next
Fila = Fila + 1
Wend
' ---&--- Busca coincidencias
For Col = 12 To 12 ' 84 Step 8
For Fil = 1 To 1 ' 150000
Total = 0: DoEvents
For a = Col To Col + 3
For b = a + 1 To Col + 4
For c = b + 1 To Col + 5
Num = (Cells(Fil, a) * 10000) + (Cells(Fil, b) * 100) + Cells(Fil, c)
Total = Total + Tabla(Num)
Next
Next
Next
Cells(Fil, Col + 7) = Total
Next
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True
Application.CutCopyMode = False
MsgBox "Fin de la Macro" & vbCrLf & _
"Tiempo de ejecucion " & Timer - Ini & " seg."
End Sub
' </> ------------------------------------------------------------------- </>
' </> ---&--- </> CUATRO COINCIDENCIAS </> ---&--- </>
' </> ------------------------------------------------------------------- </>
Sub Cuenta_4()
Dim Fila As Integer, Num As Long, Total As Integer, _
Fil As Long, Col As Integer, Ini As Single, _
Dest As Long, Ante As Long, Punt As Long
Dim Tabla(), a As Long, b As Long, c As Long, d As Long, _
Canti()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Ini = Timer
' ---&--- Crea una hoja de trabajo
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Select
Sheets(Sheets.Count).Name = "Tmp"
Sheets("Hoja1").Select
' ---&--- La tabla de consulta para 4 ACIERTOS
Fila = 5
Dest = 0
While Cells(Fila, 3) <> ""
For a = 3 To 5
For b = a + 1 To 6
For c = b + 1 To 7
For d = c + 1 To 8
Num = (Cells(Fila, a) * 1000000) + _
(Cells(Fila, b) * 10000) + _
(Cells(Fila, c) * 100) + _
(Cells(Fila, d) * 1)
Dest = Dest + 1
Sheets("Tmp").Cells(Dest, 1) = Num: DoEvents Next
Next
Next
Next
Fila = Fila + 1
Wend
' ---&--- Ordena la tabla
Columns("A:A").Select ActiveWorkbook.Worksheets("Tmp").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Tmp").Sort.SortFields.Add _ Key:=Range("A1"), _ SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("Tmp").Sort .SetRange Range("A1:A" & Dest) .Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A1").Select
' ---&--- Guarda los datos en una tabla en memoria
Punt = 0
Ante = 0
For a = 1 To Dest
If Ante <> Cells(a, 1) Then
Ante = Cells(a, 1): Punt = Punt + 1
ReDim Preserve Tabla(Punt), Canti(Punt)
Tabla(Punt) = Ante
Canti(Punt) = 1
Else
Canti(Punt) = Canti(Punt) + 1
End If
Next
Application.DisplayAlerts = False: ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
Sheets("Hoja1").Select
' ---&--- Busca coincidencias
For Col = 12 To 84 Step 8
For Fil = 1 To 150000
Total = 0: DoEvents
For a = Col To Col + 2
For b = a + 1 To Col + 3
For c = b + 1 To Col + 4
For d = c + 1 To Col + 5
Num = (Cells(Fil, a) * 10 ^ 6) + (Cells(Fil, b) * 10 ^ 4) + _
(Cells(Fil, c) * 10 ^ 2) + (Cells(Fil, d) * 10 ^ 0)
Punt = Buscar_Tabla(Tabla, Num)
If Punt > 0 Then Total = Total + Canti(Punt)
Next
Next
Next
Next
Cells(Fil, Col + 7) = Total
Next
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True
Application.CutCopyMode = False
MsgBox "Fin de la Macro" & _
vbCrLf & _
vbCrLf & _
"Tiempo de ejecucion " & Timer - Ini & " seg."
End Sub
' </> ------------------------------------------------------------------- </>
' </> ---&--- </> Busca el numero en la tabla </> ---&--- </>
' </> ------------------------------------------------------------------- </>
Function Buscar_Tabla(Tabla, Num) As Long
Dim Punt As Integer, Celda As Long, Valor As Long, Max As Long
Punt = 1
Max = UBound(Tabla)
While 2 ^ Punt < Max
Punt = Punt + 1
Wend
Punt = Punt - 1
Celda = 2 ^ (Punt): Valor = 0
' ---&---
While Punt > 0
Select Case Num
Case Is < Tabla(Celda)
Punt = Punt - 1
Celda = Celda - (2 ^ Punt)
Case Is > Tabla(Celda)
Punt = Punt - 1
Celda = Celda + (2 ^ Punt)
Case Is = Tabla(Celda)
Punt = 0
Valor = Celda
End Select
' Delimita el número maximo de lineas de la Hoja
While Celda > Max
Punt = Punt - 1
Celda = Celda - (2 ^ Punt)
Wend
Wend
If Tabla(Celda) = Num Then
Buscar_Tabla = Celda
Else
Buscar_Tabla = 0
End If
End Function
' </> ------------------------------------------------------------------- </>
' </> ---&--- </> </> ---&--- </>
' </> ---&--- </> FIN MACRO </> ---&--- </>
' </> ---&--- </> </> ---&--- </>
' </> ------------------------------------------------------------------- </>
