GENERANDO UN ALGORITMO ID3 EN VBA

Hola a todos:

Hace varias semanas que comencé a programar en VBA un algoritmo ID3 (Inducción mediante árboles de decisión). Este tipo de algoritmos se desarrollan en el campo de la Inteligencia Artificial y se engloban en los denominados algoritmos de aprendizaje.

El interés de realizar esta programación radica en la finalizad del algoritmo, es decir, su objetivo es (muy resumidamente) la búsqueda de reglas en un conjunto de ejemplos que nos van a permitir tomar decisiones, (fundamentalmente boolenas, o dicotómicas, ej: si o no).

En Internet tenéis muchos ejemplos donde se muestra el cálculo del algoritmo, en concreto os dejo este PDF: APRENDIZAJE INDUCTIVO. ÁRBOLES Y REGLAS DE DECISIÓN  (fuente: Dpto. Ciencias de Computación e Inteligencia Artificial Universidad de Sevilla), dado que contiene dos ejemplos de cálculo bien explicados.

No voy a escribir un post acerca del cálculo teórico del algoritmo (esto lo encontraréis en el PDF y en otros recursos similares en la red), me centraré en la programación del cálculo y sus resultados.

Para ilustrar el cálculo, empezaré mostrando el conjunto de ejemplos que nos servirán de base para generar el algoritmo:

GENERANDO UN ALGORITMO ID3 EN VBA

Efectivamente, se trata de un conjunto de elementos mediante los cuales tomamos la decisión de jugar o no jugar al tenis. El ejercicio se trata de determinar que nodo o variable principal será la determinante a la hora de tomar la decisión y luego el peso que tendrán el resto de atributos.

Para hallar el nodo principal, necesitamos calcular la entropía inicial sobre la que basar nuestros cálculos, esto lo haremos con esta parte del código:

Option Explicit
Sub ALGORITMO_ID3()
'AUTOR: SEGUNDO MIGUÉNS
'SITIO WEB: WWW.EXCELSIGNUM.COM
'------------------------
'CÁLCULO ENTROPIA INICIAL
'------------------------
'Variables utilizadas
'-----------------------------------------------------------
Dim fin As Long, final As Long
Dim i As Long, a As Long
Dim apalabra As String, sCadena_A As String, unicos_A As String
Dim oDic As Object
Dim matriz, nArgum
Dim sEntropia As Double, Entropia As Double
'-----------------------------------------------------------
With Sheets("DATOS")
fin = Application.CountA(.Range("1:1"))
final = Application.CountA(.Range("A:A"))
For i = 2 To final
apalabra = apalabra & "|" & .Cells(i, fin)
Next i
sCadena_A = Trim(Mid(apalabra, 2, Len(apalabra)))
Set oDic = CreateObject("scripting.dictionary")
matriz = Split(sCadena_A, "|")
For a = 0 To UBound(matriz)
If Not oDic.Exists(matriz(a)) Then oDic.Add matriz(a), matriz(a)
Next a
unicos_A = Join(oDic.Keys, "|")
For Each nArgum In Split(unicos_A, "|")
sEntropia = -(UBound(Split(sCadena_A, nArgum)) / (final - 1)) * Application.WorksheetFunction.Log(UBound(Split(sCadena_A, nArgum)) / (final - 1), 2)
Entropia = Entropia + sEntropia
Next nArgum
Sheets("RESULTADOS").Cells(1, 1) = "ENTROPÍA INICIAL"
Sheets("RESULTADOS").Cells(2, 1) = Entropia

Una vez que tenemos el resultado de la entropía inicial, que nos indicará el grado de homogeneidad de los datos, (donde “0” es totalmente homogéneo y “1” lo contrario). Para este caso el resultado es de 0,940.

El siguiente paso es la selección del atributo para el nodo raíz. Para ello, seguiremos con esta parte del código:

'----------------------------------
'SELECCION ATRIBUTO GANANCIA MAXIMA
'----------------------------------
'Variables utilizadas
'-----------------------------------------------------------------------------------------------------------
Dim n As Long, b As Long, d As Long, columna As Long, Contador As Long, g As Long, s As Long
Dim sCadena_B As String, unicos_B As String, sCadena_ganancia As String
Dim Control_bpalabra As String, Control_cpalabra As String, atributo_Ganancia As String, sCadena_C As String
Dim bpalabra, cpalabra, nGanancia, Ganancia_max As String, valor As String
Dim parte As Double, total As Double, calculo_1 As Double, numerador As Double, denominador As Double
Dim Resultado_1 As Double, pGanancia As Double, Acu_pGanancia As Double, ganancia As Double
Dim listMatriz_A As Object, resultado
'-----------------------------------------------------------------------------------------------------------
For n = 2 To fin - 1
For i = 2 To final
bpalabra = bpalabra & "|" & .Cells(i, n)
Next i
sCadena_B = Trim(Mid(bpalabra, 2, Len(bpalabra)))
Set oDic = CreateObject("scripting.dictionary")
matriz = Split(sCadena_B, "|")
For b = 0 To UBound(matriz)
If Not oDic.Exists(matriz(b)) Then oDic.Add matriz(b), matriz(b)
Next b
unicos_B = Join(oDic.Keys, "|")
For Each bpalabra In Split(unicos_B, "|")
Control_bpalabra = bpalabra
For Each cpalabra In Split(unicos_A, "|")
Control_cpalabra = cpalabra
parte = Application.WorksheetFunction.CountIfs(.Range(.Cells(2, n), .Cells(final, n)), bpalabra, .Range(.Cells(2, fin), .Cells(final, fin)), cpalabra)
total = Application.WorksheetFunction.CountIf(.Range(.Cells(2, n), .Cells(final, n)), bpalabra)
If parte = "0" Then
Resultado_1 = "0"
Else
calculo_1 = -(parte / total) * Application.WorksheetFunction.Log(parte / total, 2)
Resultado_1 = (Resultado_1 + calculo_1)
End If
Next cpalabra
pGanancia = (total / (final - 1)) * Resultado_1
Acu_pGanancia = Acu_pGanancia + pGanancia
ganancia = Round(Entropia - Acu_pGanancia, 3)
Resultado_1 = 0
Next bpalabra
atributo_Ganancia = Trim(atributo_Ganancia) & " " & ganancia
Acu_pGanancia = "0"
sCadena_ganancia = atributo_Ganancia
Next n
Set listMatriz_A = CreateObject("System.Collections.ArrayList")
For Each nGanancia In Split(atributo_Ganancia, " ")
listMatriz_A.Add nGanancia
Next nGanancia
listMatriz_A.Sort
For Each nGanancia In listMatriz_A
sCadena_C = Trim(sCadena_C) & " " & nGanancia
Next nGanancia
matriz = Split([sCadena_C], " ")
For d = LBound(matriz) To UBound(matriz)
If d = UBound(matriz) Then Ganancia_max = matriz(d)
Next
For Each nGanancia In Split(sCadena_ganancia, " ")
Contador = Contador + 1
If nGanancia = Ganancia_max Then
columna = Contador
Exit For
End If
Next
'MOSTRAMOS INFO
For Each resultado In Split(atributo_Ganancia, " ")
s = s + 1
Sheets("RESULTADOS").Cells(1, 3) = "NODOS"
Sheets("RESULTADOS").Cells(1, 4) = "SELECCION ATRIBUTO NODO RAIZ"
Sheets("RESULTADOS").Cells(s + 1, 3) = .Cells(1, s + 1)
Sheets("RESULTADOS").Cells(s + 1, 4) = resultado
Next resultado

El resultado de esta parte del código es una matriz con las ganancias de cada nodo, la mayor determinará el nodo raíz, este es el resultado:

GENERANDO UN ALGORITMO ID3 EN VBA1

Por lo tanto, el nodo raíz es el “cielo“. A partir de esta variable deberemos finalizar el cálculo con el resto de atributos para finalizar nuestro árbol de decisión. Por lo tanto, utilizaremos la parte final del código:

'--------------------------------------------------
'SELECCION GANANCIA MAXIMA RESTO DE ATRIBUTOS
'--------------------------------------------------
'Variables utilizadas
'-------------------------------------------------------------------------
Dim c As Long, e As Long, f As Long, cCol As Long, h As Long
Dim j As Long, k As Long, p As Long, t As Long
Dim dpalabra As String, sCadena_D As String, unicos_C As String, epalabra As String
Dim fpalabra As String, sCadena_E As String, unicos_D As String, Control_gArgum As String
Dim Control_hArgum As String
Dim ncampo, fArgum, gArgum, hArgum
Dim fEntropia As Double, Entropia_B As Double, parte2 As Double, total2 As Double
Dim Acu_qGanancia As Double, qGanancia As Double, calGanancia_1 As Double, Acu_calGanancia_1 As Double
Dim ganancias_2 As Double
For c = 2 To final
dpalabra = dpalabra & "|" & .Cells(c, columna + 1)
Next c
sCadena_D = Trim(Mid(dpalabra, 2, Len(dpalabra)))
Set oDic = CreateObject("scripting.dictionary")
matriz = Split(sCadena_D, "|")
For d = 0 To UBound(matriz)
If Not oDic.Exists(matriz(d)) Then oDic.Add matriz(d), matriz(d)
Next d
unicos_C = Join(oDic.Keys, "|")
For Each ncampo In Split(unicos_C, "|")
For e = 2 To final
If CStr(.Cells(e, columna + 1)) = ncampo Then
epalabra = epalabra & "|" & .Cells(e, fin)
denominador = denominador + 1
End If
Next e
sCadena_D = Trim(Mid(epalabra, 2, Len(epalabra)))
Set oDic = CreateObject("scripting.dictionary")
matriz = Split(sCadena_D, "|")
For f = 0 To UBound(matriz)
If Not oDic.Exists(matriz(f)) Then oDic.Add matriz(f), matriz(f)
Next f
unicos_C = Join(oDic.Keys, "|")
For Each fArgum In Split(unicos_C, "|")
fEntropia = -(UBound(Split(sCadena_D, fArgum)) / (denominador)) * Application.WorksheetFunction.Log(UBound(Split(sCadena_D, fArgum)) / (denominador), 2)
Entropia_B = Entropia_B + fEntropia
Next fArgum
For cCol = 2 To fin - 1
If cCol <> columna + 1 Then
For g = 2 To final
fpalabra = fpalabra & "|" & .Cells(g, cCol)
Next g
sCadena_E = Trim(Mid(fpalabra, 2, Len(fpalabra)))
Set oDic = CreateObject("scripting.dictionary")
matriz = Split(sCadena_E, "|")
For h = 0 To UBound(matriz)
If Not oDic.Exists(matriz(h)) Then oDic.Add matriz(h), matriz(h)
Next h
unicos_D = Join(oDic.Keys, "|")
For Each gArgum In Split(unicos_D, "|")
Control_gArgum = gArgum
For Each hArgum In Split(unicos_A, "|")
Control_hArgum = hArgum
parte2 = "0"
total2 = "0"
For j = 2 To final
If CStr(.Cells(j, cCol)) = gArgum And CStr(.Cells(j, fin)) = hArgum And CStr(.Cells(j, columna + 1)) = ncampo Then
parte2 = parte2 + 1
End If
Next j
For k = 2 To final
If CStr(.Cells(k, cCol)) = gArgum And CStr(.Cells(k, columna + 1)) = ncampo Then
total2 = total2 + 1
End If
Next k
If parte2 = "0" Or total2 = "0" Then
Acu_qGanancia = "0"
Else
qGanancia = -(parte2 / total2) * Application.WorksheetFunction.Log(parte2 / total2, 2)
Acu_qGanancia = (Acu_qGanancia + qGanancia)
End If
For n = 2 To final
If CStr(.Cells(n, cCol)) = gArgum And CStr(.Cells(n, fin)) = hArgum And CStr(.Cells(n, columna + 1)) = ncampo Then
numerador = numerador + 1
End If
Next n
Next hArgum
calGanancia_1 = (numerador / denominador) * Acu_qGanancia
Acu_calGanancia_1 = Acu_calGanancia_1 + calGanancia_1
ganancias_2 = Round(Entropia_B - Acu_calGanancia_1, 3)
Acu_qGanancia = 0
numerador = 0
Next gArgum
'MOSTRAR INFO
Sheets("RESULTADOS").Cells(1, 6) = "NODO RAIZ"
Sheets("RESULTADOS").Cells(t + 2, 6) = .Cells(1, columna + 1)
Sheets("RESULTADOS").Cells(1, 7) = "VARIABLES NODO RAIZ"
Sheets("RESULTADOS").Cells(t + 2, 7) = ncampo
Sheets("RESULTADOS").Cells(1, 8) = "ATRIBUTOS"
Sheets("RESULTADOS").Cells(t + 2, 8) = .Cells(1, cCol)
Sheets("RESULTADOS").Cells(1, 9) = "SELECCION DE GANANCIA MÁXIMA ATRIBUTOS"
Sheets("RESULTADOS").Cells(t + 2, 9) = ganancias_2
t = t + 1
fpalabra = vbNullString
Acu_calGanancia_1 = "0"
End If
Next cCol
Entropia_B = "0"
denominador = "0"
epalabra = vbNullString
Next ncampo
Sheets("RESULTADOS").Select
Set oDic = Nothing
Set listMatriz_A = Nothing
End With
End Sub

El resultado es el siguiente:

GENERANDO UN ALGORITMO ID3 EN VBA2

Una vez que tenemos los resultado, debemos de elegir aquellos atributos de cada uno de los nodos que dependen del nodo raíz: Soleado, Nublado y Lluvia.

La interpretación que podemos obtener después de haber generado el algoritmo es que el estado de cielo es el criterio determinante para realizar nuestra toma de decisiones, y en sus atributos, cuando el cielo está soleado y la humedad es alta no debemos jugar al tenis, tampoco cuando el cielo se encuentra lluvioso y el viento es fuerte, deberíamos ir a jugar. También deberíamos tener en cuenta si el cielo está soleado y la temperatura es alta, que no sería aconsejable ir a jugar al tenis.

Sin duda, con esta información podremos confeccionar un sencillo código condicional que nos va a permitir tomar decisiones futuras.

En un árbol de decisión, esta sería la secuencia:

GENERANDO UN ALGORITMO ID3 EN VBA3

Cuanto mayor número de ejemplos tengamos, mayor será la exactitud de las predicciones. Por ello, es aconsejable contar con una base de datos con información abundante antes de generar este tipo de algoritmos.

Soy consciente de que el código es complejo y largo, pero para poder hacerlo en un proceso continuo, es necesario contar con gran cantidad de variables, dado que tenemos que ir almacenando información que iremos utilizando a lo largo de la ejecución del código, de ahí el elevado número de variables utilizadas.

Por otra parte, aunque he extraído en cada bloque la información que a mi me parece relevante, se podrían extraer nuevas informaciones incluyendo pequeños procesos para crear cadenas de texto con los datos que se van generando, una buena forma de apreciar la información que va calculando y generando es ejecutar la macro pulsando la tecla “F8” desde el módulo de VBA.

He dejado la opción explícita en el código, dado que me ha ayudado a que no se me quedase ninguna variable sin declarar y hacer así el algoritmo más eficiente a la hora de consumir recursos.

Es muy importante que tengáis en cuenta que la salida de estos algoritmos debe ser la respuesta a preguntas dicotómicas, tipo: Verdadero – Falso, Si – No, etc.

En el archivo os encontraréis con tres pestañas:

En la primera (“DATOS”) estarán la información con la que calcularemos el algoritmo. IMPORTANTE: la primera columna siempre ha de hacer referencia al número de casos y la última a la respuesta, que como he dicho ha de ser dicotómica. Las columnas intermedias deben contener el resto de la información.

En la segunda pestaña (“RESULTADOS”), simplemente debemos pulsar el botón de comando que ejecutará el código y generará la información.

En la tercera pestaña (“EJEMPLOS”), os dejo varios casos para realizar pruebas.

Y esto ha sido todo, espero que os resulte de utilidad e interés. Puede ser una buena base para adaptarla a vuestros proyectos o cálculos.

Descarga el archivo de ejemplo pulsando en: GENERANDO UN ALGORITMO ID3 EN VBA

¿Te ha resultado de interés?, puedes apoyar a Excel Signum con una pequeña donación.

Donate Button with Credit Cards

¡¡Muchas gracias!!

Anuncios

EJECUTAR UN BUCLE EN UN RANGO DE FILAS FILTRADAS

Hola a todos!.

Hace unos días, un lector me trasladó la pregunta de cómo podría ejecutar un bucle (loop) en un rango de filas filtradas. Esto se puede realizar de diferentes formas, pero para este post quiero aprovechar y realizar un ejercicio completo con un caso práctico.

Imaginad que trabajáis de un teatro y se ha decido que para una función concreta, la asignación de sitios en las diferentes zonas del teatro se hará de una manera determinada:

Nos han enviado un listado (hoja LISTA) en el que aparecen los siguientes campos ID, FECHA, HORA, NOMBRE y LUGAR (zona del teatro), esta es la lista:

EJECUTAR UN BUCLE EN UN RANGO DE FILAS FILTRADAS

Pues bien, lo que se pretende es que asignemos un 50% de la cantidad total del número de solicitudes a cada zona y teniendo en cuenta la fecha más antigua y la hora más antigua de cada petición. Es decir que si el número total de personas que han solicitado un lugar en la Zona Premium es de 122 se marcarán los 61 primeros registros teniendo en cuenta la fecha más antigua y la hora más antigua como criterio.

Para hacer este proceso es necesario realizar varios filtros y posteriormente marcar a los clientes beneficiados. Obviamente, se puede hacer manualmente, pero … ¡el tiempo es oro! y no es cuestión de estar varias horas haciendo este proceso, o lo que es peor, imaginad que a partir de ahora siempre se hará así!.

Por lo tanto, vamos a proponer un sencillo código que nos va a ayudar a realizar esto en un segundo 🙂

Antes de ver la macro, debemos añadir otra hoja en la que vamos a indicar el nombre de todas las zonas del teatro:

EJECUTAR UN BUCLE EN UN RANGO DE FILAS FILTRADAS2

Y ahora, en un módulo estándar pegáis esta macro:

Sub BUCLE_EN_CELDAS_FILTRADAS()
'Definimos variables
Dim Fin As Integer, Final As Integer, nCasos As Integer
Dim nRango As Range, Contador As Integer, n As Integer, Dato As Range
'Desactivamos actualización de pantalla
Application.ScreenUpdating = False
'Limpiamos contenidos en el campo MARCA
With Sheets("LISTA")
Fin = Application.CountA(.Range("A:A"))
Final = Application.CountA(Sheets("ZONAS").Range("A:A"))
If Fin > 1 Then .Range("F2:F" & Fin).ClearContents
'Iniciamos bucle filtrando según ZONA y aplicando el 50 al total de personas
'con esta cifra marcaremos con otro bucle los n casos iniciales

For i = 2 To Final
'Pero antes, ordenamos por fecha, de más antigua a más reciente
nCasos = Round(Application.WorksheetFunction.CountIf(.Range("E2:E" & Fin), Sheets("ZONAS").Cells(i, 1)) * 0.5, 0)
.Range("A1:E" & Fin).AutoFilter Field:=5, Criteria1:=Sheets("ZONAS").Cells(i, 1)
With ActiveWorkbook.Worksheets("LISTA").AutoFilter.Sort
.SortFields.Clear
.SortFields.Add Key:=Range("B1:B" & Fin), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
.Header = xlYes
.Apply
End With
'Ordenamos hora, de más antigua a más reciente
With ActiveWorkbook.Worksheets("LISTA").AutoFilter.Sort
.SortFields.Clear
.SortFields.Add Key:=Range("C1:C" & Fin), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
.Header = xlYes
.Apply
End With
'Pasamos un segundo bucle para marcar con una X el 50% de los casos seleccionados
Set nRango = .Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row).SpecialCells(xlCellTypeVisible)
For Each Dato In nRango.Rows
n = 1
Contador = Contador + n
If Contador <= nCasos Then
Dato.Cells(1, 6).Value = "X"
Else
Exit For
End If
Next
Contador = 0
Selection.AutoFilter
Next
End With
'Ordenamos por ZONA y mostramos la información
Range("A1").Select
Selection.AutoFilter
With ActiveWorkbook.Worksheets("LISTA").AutoFilter.Sort
.SortFields.Clear
.SortFields.Add Key:=Range("E1:E" & Fin), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
.Header = xlYes
.Apply
Selection.AutoFilter
End With
Application.ScreenUpdating = True
End Sub

Como podéis observar, realizamos dos tipo de bucle, un for-next y un for each – next. Pero es este último (for each) en el que realmente pasamos un bucle sobre las celdas que hemos filtrado previamente según los parámetros establecidos en los datos del primer bucle.

Pulsamos el botón y tenemos este resultado:

EJECUTAR UN BUCLE EN UN RANGO DE FILAS FILTRADAS3

El código se encarga de filtrar, marcar y presentar los datos ordenador por zonas. En solo un segundo (para 800 registros).

Creo que es un ejercicio muy interesante y que podéis aplicar a multitud de tareas y proyectos. 🙂

Como siempre os dejo el archivo de descarga:

Descarga el archivo de ejemplo pulsando en: EJECUTAR UN BUCLE EN UN RANGO DE FILAS FILTRADAS

GENERAR Y EXTRAER NÚMEROS PRIMOS EN EXCEL CON VBA

Parece que los números primos están de moda, llevo un tiempo leyendo varios artículos relacionados con esta materia y realmente sus aplicaciones son muy interesantes.

Antes de nada, que creo que es importante, vamos a definir qué es un número primo: se denominan números primos aquellos números naturales que únicamente pueden ser divididos ya sea por 1 o por sí mismos.

Una vez que tenemos claro este concepto, podemos empezar a pensar en cómo nos las podemos idear para generar o para detectar números primos. Sin duda, para realizar estas tareas vamos a tener que usar algún tipo de loop o bucle que determine cifra a cifra si se trata de un número primo y en caso de serlo, anotarlo o marcarlo.

Pero el bucle necesita una herramienta que le indique si el número a evaluar es o no primo, para ello debemos utilizar la siguiente fórmula:

a - (b * Fix(a / b))

Esta fórmula realiza lo siguiente: Divide dos números y devuelve el resto o residuo de la división. Es decir, que en caso de ser número primo el número que vayamos a evaluar, debe ser 0 en dos ocasiones (en nuestro bucle), una cuando se divide entre sí mismo.

Esta fórmula se puede sustituir por el operador “MOD” en vba y funcionaría de la misma forma o por esta otra fórmula (parecida a la primera) :

a - (b * (a \ b))

En todos los casos actúa de la misma forma y sería solo cuestión de gustos o estilo el utilizar una u otra. Si os interesa os dejo el enlace donde podréis profundizar:

https://msdn.microsoft.com/es-es/library/se0w9esz.aspx

Nosotros vamos a utilizar la primera fórmula. Imaginad que nos han pedido las siguientes macros:

– Una macro que genere números primos (desean obtener los números primos entre el 1 y el 200).
– Una macro que sea capaz de extraer números primos de un listado que nos han entregado.
– Una macro que sea capaz de marcar en el listado que nos han entregado (verde) cada uno de los números primos.

Bien, (parece que el buzón de peticiones se ha cerrado por unas horas… : ) Veamos entonces la primera macro:

Sub GENERAR_NPRIM()
Dim n As Long
Dim j As Long
Dim i As Long
Dim Contador As Long
With Sheets(1)
'si exite un listado anterior lo eliminamos
fin = Application.CountA(.Range("a:a"))
If fin > 1 Then .Range("a2:a" & fin).Clear
'empezamos a generar en la celda 2
n = 2
'creamos un bucle desde 1 a límite que hayamos elegido
For i = 1 To .Cells(2, 2)
'Insertamos contador a cero
Contador = 0
'creamos un segundo bucle para comprobar si el número es o no primo
'si es igual a cero y el contador acumula 2 ceros únicamente, es primo
For j = 1 To .Cells(2, 2)
'para verificar si es primo utilizamos esta fórmula (podemos usar la función mod)
'que mostrará el resto o el residuo fruto de la división de i entre j, cumpliendo la condición
'si el resultado es cero.
primus = i - (j * Fix(i / j))
If primus = 0 Then Contador = Contador + 1
Next j
'una vez que sepamos es número primo, lo añadimos a la columna "A"
'y así con el siguiente
If Contador = 2 Then
.Range("A" & n) = i
n = n + 1
End If
Next i
End With
End Sub

Con esta macro generamos los números primos que se encuentren entre el 1 y el número que indiquemos en nuestra hoja Excel. En el ejemplo que pongo, he elegido 200:

GENERAR Y EXTRAER NUMEROS PRIMOS EN EXCEL CON VBA

Tan solo debemos indicar la cifra y pulsar en Generar, en ese momento la columna A se irá rellenando con los números primos.

Ahora vamos a por la segunda macro, una macro que nos permita extraer de una matriz numérica aquellos números que sean primos:

GENERAR Y EXTRAER NUMEROS PRIMOS EN EXCEL CON VBA2

** Es importante indicar que los números deben ser consecutivos e introducirse en orden por filas (no por columnas).

La macro que vamos a utilizar esta:

Sub EXTRAER_NPRIM()
Dim i As Range
Dim j As Range
Dim Contador As Long
Dim n As Long
With Sheets(1)
'si exite un listado anterior lo eliminamos
fin = Application.CountA(.Range("D:D"))
If fin > 1 Then .Range("D2:D" & fin).Clear
'incluimos un control error en caso de ejecutar la macro sin seleccionar datos
On Error GoTo Control
'área será el rango que vayamos a seleccionar
Set area = Application.Intersect(Selection, .UsedRange)
'empezamos a generar en la celda 2
n = 2
'iniciamos un bucle que recorra cada uno de las celdas en "área"
For Each i In area
'Insertamos contador a cero
Contador = 0
'iniciamos un segundo bucle comprando cada uno de los números de nuestra selección con el resto
'verificando así si se trata de un número primo
For Each j In area
primus = i - (j * Fix(i / j))
If primus = 0 Then Contador = Contador + 1
Next j
'una vez que sepamos es número primo, lo añadimos a la columna "A"
'y así con el siguiente
If Contador = 2 Then
.Range("D" & n) = i
n = n + 1
End If
Next i
Control: If Err.Number = "6" Or Err.Number = "13" Then
MsgBox ("EL RANGO SELECCIONADO NO CONTIENE DATOS"), vbExclamation, "EXTRAER NÚMEROS PRIMOS"
End If
End With
End Sub

A diferencia de la primera macro, en este caso utilizamos un bucle for each, dado que lo que vamos a evaluar son las celdas de un rango definido (área).

Para ejecutar la macro, es necesario seleccionar todo el rango de datos y luego pulsar en el botón: “Extraer números primos”. En ese momento en la columna “D” se irán colocando los números de la matriz que son primos. Dado que la matriz va desde el 1 al 200 los datos deben ser idénticos a los que hemos generado en la primera macro. Este es el resultado:

GENERAR Y EXTRAER NUMEROS PRIMOS EN EXCEL CON VBA3

Efectivamente, los datos de la columna “D” son idénticos a los de la columna “A”, verificando doblemente los cálculos.

Por último, esta otra macro marcará de color verde en la matriz los números que haya detectado como primos:

Sub MARCAR_NPRIM()
Dim i As Range
Dim j As Range
Dim Contador As Long
With Sheets(1)
'incluimos un control error en caso de ejecutar la macro sin seleccionar datos
On Error GoTo Control
'área será el rango que vayamos a seleccionar
Set area = Application.Intersect(Selection, .UsedRange)
'si exiten celdas marcadas anteriormente, eliminamos color
With Selection.Interior
.Pattern = xlNone
End With
'iniciamos un bucle que recorra cada uno de las celdas en "área"
For Each i In area
'Insertamos contador a cero
Contador = 0
'iniciamos un segundo bucle comprando cada uno de los números de nuestra selección con el resto
'verificando así si se trata de un número primo
For Each j In area
primus = i - (j * Fix(i / j))
If primus = 0 Then Contador = Contador + 1
Next j
If Contador = 2 Then
'en el momento que sabemos que el número es primo, marcamos en verde la celda
area(i).Interior.Color = vbGreen
End If
Next i
Control: If Err.Number = "6" Or Err.Number = "13" Then
MsgBox ("EL RANGO SELECCIONADO NO CONTIENE DATOS"), vbExclamation, "MARCAR NÚMEROS PRIMOS"
End If
End With
End Sub

Este caso no deja de ser una variante de la macro anterior, solo que ahora no extraemos datos, solo debemos marcar. Este es el resultado:

Importante, en esta macro, debemos seleccionar todo el rango de datos, desde el 1 al 200, en caso contrario, no marcará correctamente los números.

GENERAR Y EXTRAER NUMEROS PRIMOS EN EXCEL CON VBA4

y con esta macro finalizamos los trabajos que nos habían pedido sobre números primos.

Aunque en las dos últimas macros debemos seleccionar el rango de datos para extraer y marcar los números primos, si seleccionamos un rango sin datos el control de error nos avisará.

Debemos recordar que estamos trabajando con Excel y con VBA, y aunque son herramientas muy potentes, tienen limitaciones, en este caso las propias variables que hemos declarado y por otra parte las limitaciones de la hoja.

Aunque el archivo es .xls lo podéis guardar como .xlsm y tendréis todos las mejoras de 2007 en adelante.

De todas formas intentar generar los números primos entre 1 y 200.000 puede tardar varias horas. Y eso es todo, me ha parecido un ejercicio muy interesante y creo que bastante útil en algunas áreas profesionales.

PD: el 1 no se considera número primo, por ello no he programado las macros para que lo detecten.

Descarga el archivo de ejemplo pulsando en: GENERAR Y EXTRAER NÚMEROS PRIMOS EN EXCEL CON VBA