MS Excel 2003: contar pares coincidentes

Los datos expuestos en este blog, son solo de índole informativo. Por favor realiza siempre una copia de seguridad antes de realizar cualquier cambio en tu proyecto.

MS Excel 2003: contar pares coincidentes

Este tutorial de Excel explica cómo escribir una macro para contar el número de pares coincidentes en Excel 2003 y versiones anteriores (con capturas de pantalla e instrucciones paso a paso).

P: En Microsoft Excel 2003/XP/2000/97, tengo una hoja de cálculo con los números ganadores de la lotería. Quiero contar cuántas veces aparece un par de números en varios sorteos. ¿Cómo puedo hacer esto?

Respuesta: Esto se puede hacer usando código VBA para generar conteos de pares coincidentes y luego usando la función BUSCARV para mover el resultado a una matriz.

Veamos un ejemplo.

Descargue la hoja de cálculo de Excel (que se muestra a continuación)

En esta hoja de cálculo de ejemplo, tenemos una tabla llamada “Datos de sorteo” que contiene los números ganadores de varios sorteos. Hay un botón en esta hoja llamado “Actualizar estadísticas de pares” que llama a una macro llamada UpdatePairStats.

Cuando se ejecuta la macro, completará una hoja llamada “PairStats” con recuentos de pares coincidentes, como este:

Cuando se complete la macro, aparecerá el siguiente cuadro de mensaje:

En la hoja denominada Pares, verá que la matriz se rellena con logaritmos coincidentes (según la fórmula BUSCARV).

La matriz utiliza la siguiente fórmula (la celda C2 contiene la siguiente fórmula):

=IF(ISNA(VLOOKUP(Pairs!$A2 & "." &Pairs!C$1,PairStats!$A:$D,4,FALSE)),"",VLOOKUP(Pairs!$A2 & "." &Pairs!C$1,PairStats!$A:$D,4,FALSE))

Lo que hace esta fórmula es realizar una BUSCARV en números concatenados (separados por “.”). Si no se encuentra ninguna coincidencia, se devuelve una cadena vacía (“”).

Puede presionar Alt+F11 para ver el código VBA.

codigo macro

El código de la macro se ve así: (que se encuentra en el Módulo 1)

Sub UpdatePairStats()

   Dim LRange As Variant
   Dim LRows As Long
   Dim LCols As Long
   Dim C As New Collection
   Dim LItem As Long
   Dim LDesc As String
   Dim Counts(10000, 4) As String
   Dim i As Long, j As Long, k As Long

   On Error Resume Next

   'Select sheet where data resides
   Sheets("Draw Data").Select

   'Data range (where draw information resides)
   LRange = Range("C2:H1151")

   LRows = UBound(LRange, 1)
   LCols = UBound(LRange, 2)

   'Loop through each row in LRange (find pairs)
   For i = 1 To LRows

      'j and k create the pairs
      For j = 1 To LCols - 1

         For k = j + 1 To LCols
            'Separate pairs with a "." character (smaller number first)
            If LRange(i, j) < LRange(i, k) Then
               LDesc = LRange(i, j) & "." & LRange(i, k)
            Else
               LDesc = LRange(i, k) & "." & LRange(i, j)
            End If

            'Add new item to collection ("on error resume next" is
            'required above in this procedure because of this line of code)
            C.Add C.Count + 1, LDesc

            'Retrieve indexnumber of new item
            LItem = C(LDesc)

            'Add pair information to new item
            If Counts(LItem, 0) = "" Then
               Counts(LItem, 0) = LDesc
               Counts(LItem, 1) = LRange(i, j)
               Counts(LItem, 2) = LRange(i, k)
            End If

            'Increment stats counter
            If Counts(LItem, 3) = "" Then
               Counts(LItem, 3) = "1"
            Else
               Counts(LItem, 3) = CStr(CInt(Counts(LItem, 3)) + 1)
            End If

         Next k
      Next j
   Next i

   'Paste pairs onto sheet called PairStats
   Sheets("PairStats").Select
   Cells.Select
   Selection.Clear
   Cells(1, 1).Resize(C.Count, 4) = Counts

   'Format headings
   Range("A1").FormulaR1C1 = "'Number1.Number2"
   Range("B1").FormulaR1C1 = "'Number1"
   Range("C1").FormulaR1C1 = "'Number2"Range("D1").FormulaR1C1 = "'Occurrences"

   Range("A1:D1").Select
   Selection.Font.Bold = True
   Selection.Font.Underline = xlUnderlineStyleSingle

   Columns("A:D").EntireColumn.AutoFit
   Range("F1").Select
   Range("F1").FormulaR1C1 = "Last Updated on " & Now()

   Sheets("Pairs").Select
   MsgBox "Pair statistics have been updated."

End Sub

Tenga en cuenta que usted tiene que personalizar Alcance variable para que coincida con el número de filas y columnas de datos.