CALCULAR LA EDAD CON DATEDIF EN UN FORMULARIO DE EXCEL

Hola a todos, espero que estéis bien y supongo que ya disfrutando de vacaciones (a mí aún me quedan unas semanas para comenzarlas).

En el post de hoy vamos a tratar de resolver una consulta que me enviaron la semana pasada sobre un tema que ya hace tiempo que tenía ganas de abordar. La pregunta era cómo se podía calcular la edad en un formulario de Excel.

Bien, existen varios post sobre el cálculo de la edad en esta web, y en todas ellas usamos la función SIFECHA() de excel, que normalmente la usamos en la hoja y en menor medida en VBA. En VBA esta función se denomina DATEDIF (y NO es lo mismo que otra función denominada DATEDIFF, que trabaja con valores absolutos).

Esta función, si utilizamos la grabadora de datos para obtener su traducción en VBA sería algo así:

AÑO = "=DATEDIF(RC[-12],TODAY(),""Y"")"

Es decir, nos ofrece la posibilidad de generar la fórmula en la hoja desde VBA. Pero lo cierto es que queremos trabajar con esta función sin acudir a la hoja en ningún momento, simplemente utilizar el formulario y los parámetros que hayamos incluido para calcular la edad de una persona.

Aunque esta función no existe en VBA como tal, podemos invocarla a través del método EVALUATE, aunque eso lo iremos viendo en el caso particular que nos ocupa.

Vamos a imaginar que tenemos un formulario con un cuadro de texto (textbox1) en el que debemos incluir la fecha de nacimiento, un botón de comando para ejecutar la macro y otro cuadro de texto (textbox2) en el que vamos a mostrar la edad completa:

CALCULAR LA EDAD EN UN FORMULARIO

Para calcular la edad vamos a incluir en modulo asociado al botón de comando el siguiente código:

Private Sub CommandButton1_Click()
'Definimos variables
Dim validarfecha As Boolean
Dim hoy As String
Dim f_nac As String
Dim año As Double, mes As Double, dia As Double
'Trabajamos con el formulario1
With UserForm1
'Cada vez que ejecutemos la macro vaciaremos el textbox1
.TextBox2 = Empty
'Si no existe fecha o el dato no es una fecha o está mal escrita, activamos mensaje y salimos el cálculo
validarfecha = IsDate(.TextBox1.Value)
If .TextBox1.Value = Empty Or validarfecha = False Or Len(.TextBox1.Value) > 10 Then
MsgBox ("DEBES INTRODUCIR UNA FECHA Y VERIFICAR QUE EL FORMATO SEA EL ADECUADO"), vbExclamation, "CONTROL"
Exit Sub
End If
'Si la fecha es mayor que la fecha actual, activamos mensaje y salimos el cálculo
If CDate(.TextBox1.Value) > Date Then
MsgBox ("LA FECHA NO PUEDE SER MAYOR QUE EL DÍA ACTUAL"), vbExclamation, "CONTROL"
Exit Sub
Exit Sub
End If
'Indicamos la fecha de hoy con formato mm/dd/aaaa y lo componemos en un string
hoy = (Month(Date) & "/" & Day(Date) & "/" & Year(Date))
'Indicamos la fecha de hoy con formato mm/dd/aaaa y lo componemos en un string
f_nac = (Month(.TextBox1.Value) & "/" & Day(.TextBox1.Value) & "/" & Year(.TextBox1.Value))
'Evaluamos la función Datedif para año, mes y día
año = Evaluate("DATEDIF(""" & f_nac & """,""" & hoy & """,""Y"")")
mes = Evaluate("DATEDIF(""" & f_nac & """,""" & hoy & """,""YM"")")
dia = Evaluate("DATEDIF(""" & f_nac & """,""" & hoy & """,""MD"")")
'Pasamos el string con los años, meses y días de nuestra edad actual al textbox2
.TextBox2 = año & IIf(año = 1, " año", " años") & ", " & mes & IIf(mes = 1, " mes", " meses") & " y " & dia & IIf(dia = 1, " dia", " días")
End With
End Sub

Es importante tener en cuenta que la función reconoce la fecha con formato mm/dd/aaaa por lo que debemos especificar esto tanto para la variable que contiene la fecha actual “hoy” como para la que contiene la fecha de nacimiento “f_nac”. Esto lo podemos solucionar componiendo un string con la fecha en el orden indicado.

En el cuadro de texto de la fecha de nacimiento el formato es el habitual: días, meses y años. Si necesitáis introducir los datos con otro formato, tendréis que modificar la macro en los dos string creados para que la función lea adecuadamente la información.

Luego debemos adaptar la función para trabajar con variables y evaluarla con el método Evaluate. Importante el uso de las comillas.

El resultado es el siguiente (calculado sábado 22 de Julio de 2017 a las 23:22 horas):

CALCULAR LA EDAD EN UN FORMULARIO1

Y el resultado es el correcto (y también lo es que me voy haciendo más viejo). El formulario me muestra información completa de la edad que tengo en el momento de ejecutar el código.

He incluido en la macro varios controles: si no existe fecha, si la fecha está mal escrita o si es mayor que el día actual. Si sucede alguna de estas cosas, mostrará un mensaje y proceso finalizará.

Según configuraciones regionales las fechas tendrán formatos distintos, sin embargo, creo que adaptando la macro a meses, días y años funcionará en todos los lugares (siempre que escribamos la fecha de nacimiento con día, mes y año.

Pues esto ha sido todo, espero que os sea de utilidad a la hora de crear formularios o de poner en práctica la función Datedif en VBA.

Descarga el archivo de ejemplo pulsando en: CALCULAR LA EDAD EN UN FORMULARIO DE EXCEL

 

Anuncios

REALIZAR BUCLES ANIDADOS Y BUSCAR VALORES APROXIMADOS

Hola a todos 🙂

Siguiendo con una consulta recibida el fin de semana pasado, un lector solicitaba una macro que recorriese varias columnas y otro bucle anidado que recorriese las celdas de cada columna. A su vez preguntaba la forma de detectar un importe determinado y las aproximaciones según un rango establecido.

Aunque ya existen en la web algunas macros que realizar este trabajo en parte (realizando algunas modificaciones), creo que puede ser interesante compartir con vosotros un nuevo desarrollo.

Para ejemplificar el ejercicio, imaginad que tenéis una tabla varias columnas identificadas con los meses del año, y en cada columna una serie de importes (podéis poner la moneda que queráis, yo lo he dejado con euros):

REALIZAR BUCLES ANIDADOS Y BUSCAR VALORES APROXIMADOS

Pues bien, necesitamos una macro que nos busque un importe determinado que vamos a colocar en la celda “N2” en el campo denominado IMPORTE y además que detecte aquellos valores que se aproximen a ese número según un rango que establezcamos en la celda “O2” en el campo denominado “APROX”.

Para este ejemplo vamos a buscar aquellas celdas que sean igual a 50.000 euros y con aproximaciones de 5.000 euros.

Es decir, debemos marcar además de los 50.000 euros (Rojo), cualquier cifra hasta los 55.000 euros (Verde) y cualquier cifra hasta los 45.000 euros (Azul).

Para ello vamos a usar esta macro que he programado con la que realizaremos el trabajo que nos han pedido:

Sub BUSCAR_VALORES_APROXIMADOS()
'Definimos variables
Dim i As Integer
Dim nNUM As Double
Dim sVAR As Double
'Desactivamos actualizacion de pantalla
Application.ScreenUpdating = False
'Hacemos referencia a la Hoja1 para los cálculos
With Sheets("Hoja1")
'Eliminamos colores de relleno anteriores
.Range("A2", Range("A2").End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Interior.Pattern = xlNone
'Incluimos en las variables cifra a buscar y aproximaciones
nNUM = .Range("N2")
sVAR = .Cells(2, 15)
'Determinamos cuantas columnas tenemos (datos consecutivos)
Fin = Application.CountA(.Range("A1", Range("A1").End(xlToRight)))
'Iniciamos primer bucle por columnas
For i = 1 To Fin
'Determinamos el rango de cada columnas, desde la celda 1 hasta el final con datos
Final = Application.CountA(.Range(Cells(1, i), Cells(1, i).End(xlDown)))
'Iniciamos segundo bucle por celda en cada columna
For j = 2 To Final
'Si el valor de la celda es igual a nNUM marcamos en rojo
If .Cells(j, i) = nNUM Then
.Cells(j, i).Interior.Color = vbRed
'Si el valor de la celda esta entre nNUM y la aproximación en "positivo" marcamos en verde
ElseIf .Cells(j, i) <= nNUM + sVAR And .Cells(j, i) > nNUM Then
.Cells(j, i).Interior.Color = RGB(51, 204, 51)
'Si el valor de la celda esta entre nNUM y la aproximación en "negativo" marcamos en azul
ElseIf .Cells(j, i) >= nNUM - sVAR And .Cells(j, i) < nNUM Then
.Cells(j, i).Interior.Color = RGB(60, 144, 246)
End If
Next
Next
.Range("N2").Select
End With
Application.ScreenUpdating = True
End Sub

Como podéis ver, según vais leyendo los comentarios de la macro, mediante dos bucles, uno de ellos anidado, vamos buscando por cada celda según la columna seleccionada los valores que hemos indicado en el condicional.

Esto nos permitirá modificar las condiciones y los parámetros para adaptar el código a nuestras necesidades.

El resultado que se muestra es este:

REALIZAR BUCLES ANIDADOS Y BUSCAR VALORES APROXIMADOS1

Para este ejercicio he utilizado un loop for – next, pero se podría realizar con otros tipos de bucle y otros métodos de búsqueda, por ejemplo con el método Range.Find, etc.Pero creo que esta forma es más adecuada según los parámetros de la consulta.

Es interesante su uso en aplicaciones o informes con grandes cantidades de información y en el que necesitemos resaltar, extraer o modificar valores determinados.

Descarga el archivo de ejemplo pulsando en: REALIZAR BUCLES ANIDADOS Y BUSCAR VALORES APROXIMADOS

 

COMPROBAR SI EXISTEN ERRORES EN LAS FORMULAS DE NUESTRO ARCHIVO CON VBA

Hola a todos!

Espero que estéis bien 🙂

En el post de hoy voy a tratar el tema de los errores en fórmulas y cómo podemos detectarlos utilizando VBA.

Una forma de hacer esto sin recurrir a macros, es entrando en la ficha Inicio > “Ir a Especial” y seleccionar “Celdas con fórmulas” (aunque no las marcará):

COMPROBAR SI EXISTEN ERRORES EN LAS FORMULAS DE NUESTRO ARCHIVO CON VBA

O utilizando la ficha formato condicional que permite verificar y marcar cualquier error en el rango indicado:

COMPROBAR SI EXISTEN ERRORES EN LAS FORMULAS DE NUESTRO ARCHIVO CON VBA2

Pero siempre está bien crear nuevas alternativas que agilicen nuestros procesos, para este caso implementaré una macro que verifique en cada hoja si existen errores y en caso afirmativo, pinte de rojo la celda y muestre un mensaje de advertencia indicando que existen errores.

Como en el post anterior traté el tema de los métodos de depreciación, y el archivo tiene bastantes fórmulas nos servirá de ejemplo.

Para ello voy a crear cuatro pestañas con el mismo archivo, pero introduciendo errores en las fórmulas para luego detectarlos, en cada hoja introduciré un error distinto para comprobar que la macro funciona correctamente.

Y a continuación ejecuto el siguiente código:

Sub BUSCAR_ERRORES()
'Declaramos variables
Dim i As Integer, nHoja As Integer, X As Integer
'Contamos las hojas que tenemos en nuestros libro
nHoja = ActiveWorkbook.Worksheets.Count
'Iniciamos un loop para recorrer todas las hojas
For i = 1 To nHoja
Sheets(i).Select
Range("A1").Select
'Detectamos si existen errores en las hojas y marcamos celdas en rojo
'Controlamos error que se muestra si no existen formulas con errores
On Error Resume Next
Selection.SpecialCells(xlCellTypeFormulas, 16).Select
If Err.Number <> "1004" Then
X = X + 1
Selection.Interior.Color = vbRed
End If
On Error GoTo 0
Next
'Mostramos mensaje informativo o de advertencia
If X > 0 Then
MsgBox ("REVISA EL ARCHIVO, EXISTEN ERRORES"), vbExclamation, "INFORME"
Else
MsgBox ("ARCHIVO SIN ERRORES"), vbInformation, "INFORME"
End If
End Sub

El resultado es el siguiente:

Hoja1:

COMPROBAR SI EXISTEN ERRORES EN LAS FORMULAS DE NUESTRO ARCHIVO CON VBA3

Hoja2:

COMPROBAR SI EXISTEN ERRORES EN LAS FORMULAS DE NUESTRO ARCHIVO CON VBA4

Hoja3:

COMPROBAR SI EXISTEN ERRORES EN LAS FORMULAS DE NUESTRO ARCHIVO CON VBA5

Y en la hoja4 no hay nada marcado porque no existen errores:

COMPROBAR SI EXISTEN ERRORES EN LAS FORMULAS DE NUESTRO ARCHIVO CON VBA6

Esta macro tiene la ventaja de ser muy rápida y que la podemos aplicar de una vez a todo el libro. Sin duda resulta de gran ayuda para evitar equivocaciones en nuestros cálculos!.

Espero que os resulte útil, no cuesta nada pegar la macro en un módulo estándar y ejecutarla 🙂

Descarga el archivo de ejemplo pulsando en: COMPROBAR SI EXISTEN ERRORES EN LAS FÓRMULAS DE NUESTROS ARCHIVOS CON VBA

EXTRAER DATOS DE UNA CADENA DE TEXTO DE DOS EN DOS O MÁS CARACTERES

Hola a todos:

Hace unos días me llegó una consulta donde solicitaban extraer información de una cadena de datos. Sobre esta temática hay varios post dedicados en la web 🙂

Aquí lo que me pedían era el modo de extraer datos de dos en dos y pasarlos a columnas contiguas. Es un trabajo sencillo pero requiere modificar la macro desarrollada en este post: EXTRAER INFORMACIÓN ESPECÍFICA DE UNA CADENA ALFANUMÉRICA UTILIZANDO TEXTO EN COLUMNAS

Realmente lo que vamos a necesitar es fragmentar esa cadena de datos de dos en dos y con un espacio entre cada par de números, para luego utilizar texto en columnas y separar por espacios.

Pues bien, vamos a utilizar este ejemplo:

EXTRAER DATOS DE UNA CADENA DE TEXTO DE DOS EN DOS O MAS CARACTERES

en este caso trabajamos con datos numéricos y formato numérico, pero funciona perfectamente para texto. Y utilizaremos la siguiente macro:

Sub Extrae_n_caracteres()
'Definimos variables
Dim i As Integer, j As Integer, n As Integer, fin As Integer
Dim nCampos As Integer, n_Colum As Integer
Dim miCelda As String, sCadena As String, nPar As String
Dim miArray As Variant, iArray As Variant
'Iniciamos la macro
With Sheets("DATOS")
Application.ScreenUpdating = False
fin = Application.CountA(.Range("A:A"))
'Borramos información a partir de la columna "B"
.Range(.Cells(2, 2), ActiveCell.SpecialCells(xlLastCell)).Select
Selection.ClearContents
'Iniciamos bucle para recorrar todas las filas
For j = 2 To fin
sCadena = vbNullString
miCelda = .Cells(j, 1)
'Vaciamos variable scadena
For i = 1 To Len(miCelda) Step 2
'Extraemos de 2 en 2
nPar = Mid(miCelda, i, 2)
'Añadimos un espacio cada dos números
sCadena = sCadena & " " & nPar
Next
'Eliminamos espacios al principio y final
miCelda = Trim(sCadena)
'Pasamos la cadena a la segunda columna
.Cells(j, 2) = Trim(sCadena)
'Dimensionamos matrices con los datos que tenemos en miCelda
'para determinar las columnas de la función textToColumns
nCampos = Len(.Cells(j, 2))
nCampos = nCampos - 1
ReDim miArray(0 To nCampos)
For n_Colum = 0 To nCampos
ReDim iArray(0 To 1)
iArray(0) = n_Colum + 1
iArray(1) = 2
miArray(n_Colum) = iArray
Next n_Colum
'Aplicamos la función texto en columnas a partir de la segunda columna
'delimitamos el texto en caracteres (en este ejemplo utilizamos los espacios).
Cells(j, 2).TextToColumns Destination:=Range("B" & j), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Space:=True, FieldInfo:=miArray
'Indicamos que todas las matrices tengan formato general, pero podríamos indicar que sea número, etc
Next
.Cells(j, 1).Select
End With
End Sub

El resultado será el siguiente:

EXTRAER DATOS DE UNA CADENA DE TEXTO DE DOS EN DOS O MAS CARACTERES2

Podríamos modificar los parámetros para extraer de tres en tres: modificando los parámetros de la macro (en rojo)

For i = 1 To Len(miCelda) Step 3
'Extraemos de 3 en 3
nPar = Mid(miCelda, i, 3)
'Añadimos un espacio cada tres números
sCadena = sCadena & " " & nPar
Next

EXTRAER DATOS DE UNA CADENA DE TEXTO DE DOS EN DOS O MAS CARACTERES3

o de cuatro en cuatro:

For i = 1 To Len(miCelda) Step 4
'Extraemos de 4 en 4
nPar = Mid(miCelda, i, 4)
'Añadimos un espacio cada tres números
sCadena = sCadena & " " & nPar
Next

EXTRAER DATOS DE UNA CADENA DE TEXTO DE DOS EN DOS O MAS CARACTERES4

Incluso podríamos extraer cada n posiciones repitiendo el último número del fragmento anterior:

For i = 1 To Len(miCelda) Step 1
'Extraemos de 2 en 2 y añadiendo en número del fragmento anterior
nPar = Mid(miCelda, i, 2)
'Añadimos un espacio cada dos números
sCadena = sCadena & " " & nPar
Next

EXTRAER DATOS DE UNA CADENA DE TEXTO DE DOS EN DOS O MAS CARACTERES5

Y este ha sido el resultado de la consulta, que le sirvió a nuestro lector perfectamente para seguir con su proyecto 🙂

Espero que os sea de utilidad también a vosotros.

Descarga el archivo de ejemplo pulsando en: EXTRAER DATOS DE UNA CADENA DE TEXTO DE DOS EN DOS O MAS CARACTERES

 

GENERANDO UN ALGORITMO GENÉTICO EN VBA

Hola a todos 🙂

Espero que estéis bien! Además dadas las fechas en las que estamos, seguro que algunos de vosotros ya estaréis empezando las vacaciones!.

En el post de hoy vamos a tratar un tema que está bastante de moda, los algoritmos evolutivos y dentro de estos, los algoritmos genéticos.

Dentro de los algoritmos genéticos existen multitud de tipos de cálculo y técnicas para obtener una simulación de cruce genético, es decir de creación y combinación de cadenas de ADN tras cada generación.

Dado que esto es un proceso, lo podemos programar en VBA (al igual que en otros muchos lenguajes de programación).

En la red hay muchos ejemplos de programación, de mayor o menor complejidad, pero que en esencia realizan los mismos pasos:

  • Generación del material a tratar (cromosomas).
  •  Elección del % de material óptimo (cromosomas más aptos), según criterio seleccionado.
  •  Cruce del los cromosomas óptimos, según criterio seleccionado.
  •  Generación de nuevos cromosomas.
  •  Repetición del proceso tantas veces por generaciones que se quieran establecer.

A partir de aquí, debemos utilizar las técnicas y procedimientos de programación que mejor se ajusten a nuestro proyecto.

Como sabéis, cuando realizo un post, me gusta explicarlo bien. Que todo lector con curiosidad pueda comprender y realizar los mismos ejercicios que se proponen, es la fisolofía de esta web. Por ello, trataré de ser lo más claro posible y también de utilizar funciones y procedimientos claros en el código. Esto lo comento porque muchos de los ejemplos que circulan por la red además de ser bastante complejos, el código utilizado es dificil de seguir y comprender.

Una vez realizada esta introducción, vamos a empezar con el ejercicio paso por paso.

La situación de partida propuesta es que queremos generar X número de cromosomas con una longitud determinada y que contará con números aleatorios comprendidos del 1 al 9 (he excluido el cero para no tener que estar formateando celdas con formato texto).

Nuestro archivo Excel tendrá dos pestañas, una la llamaremos MATRIZ y otra REPORT. En la hoja MATRIZ realizaremos todos los cálculos y en REPORT mostraremos detalle de los resultados.

Contaremos con cuatro módulos, aunque el módulo principar se llama INICIAL, aquí vamos a incluir el siguiente código, que incluirá llamadas a las otras tres macros. Os muestro este código y lo vamos comentando paso a paso:

Sub MODELO_ALGORITMO_GENETICO()
'Declaramos variables
Dim Min As Integer, Max As Integer, GEN As String, GENOTIPO As String
Dim COMBO As Integer
Dim i As Integer, n As Integer, b As Integer, j As Integer
'Limpiamos hoja REPORT
Sheets("REPORT").Select
Cells.Select
Selection.ClearContents
Range("A1").Select
'Limpiamos rango de cálculos en MATRIZ
Sheets("MATRIZ").Select
With Sheets("MATRIZ")
pTotal = Application.CountA(Range("A:A"))
If pTotal > 1 Then .Range("A2:E" & pTotal).Clear
'Generamos lista consecutiva de casos
.Cells(1, 1) = "Nº DE CASOS"
For i = 2 To .Cells(2, 10) + 1
.Cells(i, 1) = i - 1
Next
'Creamos individuos
pTotal = Application.CountA(Range("A:A"))
.Cells(1, 2) = "POBLACIÓN INICIAL"
For i = 2 To pTotal
Min = 1
Max = 9
GEN = vbNullString
For n = 1 To .Cells(2, 11)
COMBO = Application.WorksheetFunction.RandBetween(Min, Max)
GEN = COMBO & GEN
Next n
Cells(i, 2) = GEN
Next i
'Creamos genotipo a comparar
.Cells(1, 7) = "GENOTIPO"
GENOTIPO = vbNullString
For n = 1 To .Cells(2, 11)
COMBO = Application.WorksheetFunction.RandBetween(Min, Max)
GENOTIPO = COMBO & GENOTIPO
Next n
Cells(2, 7) = GENOTIPO
'Iniciamos bucle por cada generación
For b = 1 To .Cells(2, 8)
If b > 1 Then
For j = 2 To pTotal
.Cells(j, 2) = .Cells(j, 5)
Next j
End If
'Llamamos al resto de macros para generar la información
Call CALIFICACIONES
Call APTOS
Call N_POBLACION
'Generamos informe resumen en la hoja REPORT
For i = 2 To pTotal
With Sheets("REPORT")
.Cells(i, 1) = Worksheets(1).Cells(i, 1)
.Cells(1, b + 1) = b & "ª" & " " & "GENERACION"
.Cells(i, b + 1) = Worksheets(1).Cells(i, 5)
.Cells(1, 1) = "Nº CASOS"
End With
Next i
Next b
End With
End Sub

Cuando lo ejecutemos, lo primero que va a hacer es limpiar de contenidos la parte del cálculo de la hoja MATRIZ y la hoja REPORT.

A continuación, generamos lista ordenada de número de casos para la muestra:

'Generamos lista consecutiva de casos
With Sheets("MATRIZ")
pTotal = Application.CountA(Range("A:A"))
If pTotal > 1 Then .Range("A2:E" & pTotal).Clear
'Generamos lista consecutiva de casos
.Cells(1, 1) = "Nº DE CASOS"
For i = 2 To .Cells(2, 10) + 1
.Cells(i, 1) = i - 1
Next

En nuestra hoja Matriz crearemos un campo para determinar el rango máximo de casos (.Cells(2, 10)+1) en este ejemplo será 10:

El resultado es este:

GENERANDO UN ALGORITMO GENETICO EN VBA

A continuación debemos crear nuestra población de cromosomas, teniendo en cuenta que su longitud será de 10 posiciones con números aleatorios del 1 al 9:

'Creamos individuos
pTotal = Application.CountA(Range("A:A"))
.Cells(1, 2) = "POBLACIÓN INICIAL"
For i = 2 To pTotal
Min = 1
Max = 9
GEN = vbNullString
For n = 1 To .Cells(2, 11)
COMBO = Application.WorksheetFunction.RandBetween(Min, Max)
GEN = COMBO & GEN
Next n
Cells(i, 2) = GEN
Next i

Este es el resultado:

GENERANDO UN ALGORITMO GENETICO EN VBA1

El siguiente paso, será el de crear el GENOTIPO, o gen modelo con el que vamos a comparar el resto de genes:

'Creamos genotipo a comparar
.Cells(1, 7) = "GENOTIPO"
GENOTIPO = vbNullString
For n = 1 To .Cells(2, 11)
COMBO = Application.WorksheetFunction.RandBetween(Min, Max)
GENOTIPO = COMBO & GENOTIPO
Next n
Cells(2, 7) = GENOTIPO

Y con esto ya tenemos los elementos necesarios para iniciar el cálculo:

GENERANDO UN ALGORITMO GENETICO EN VBA2

El siguiente paso, será generar un loop que repita el proceso tantas veces como lo hayamos indicado en la celda (2,8) de la hoja MATRIZ y a través del cual generemos el resto de macros

'Iniciamos bucle por cada generación
For b = 1 To .Cells(2, 8)
If b > 1 Then
For j = 2 To pTotal
.Cells(j, 2) = .Cells(j, 5)
Next j
End If
'Llamamos al resto de macros para generar la informacion
Call CALIFICACIONES
Call APTOS
Call N_POBLACION

En la primera de las macros, vamos a otorgar puntuación a cada uno de los cromosomas, esto lo vamos a hacer, contanto las veces que un número del genotipo se repite en un cromosoma, a más repeticiones, mayor calificación y por lo tanto más apto, esta es la macro:

Sub CALIFICACIONES()
'Declaramos variables
Dim pTotal As Integer, j As Integer, GEN As Integer
Dim apto As Integer, r As Integer, i As Integer
With Sheets("MATRIZ")
pTotal = Application.CountA(.Range("A:A"))
'Contamos las veces que se repite cada número de cada cromosoma con los números del genotipo de comparación
.Cells(1, 4) = "SELECCION"
For j = 2 To pTotal
apto = 0
For r = Len(.Cells(2, 7)) To 1 Step -1
GEN = Mid(.Cells(2, 7), r, 1)
For i = Len(.Cells(j, 2)) To 1 Step -1
If Mid(.Cells(j, 2), i, 1) = GEN Then
apto = apto + 1
End If
Next i
Next r
'Mostramos resultado
.Cells(j, 3) = apto
Next j
End With
End Sub

y este es el resultado:

GENERANDO UN ALGORITMO GENETICO EN VBA3

El siguiente paso es llamar a la macro APTOS que se encuentra en el módulo FITNESS, para seleccionar el % de mejores genes que hemos indicado en la hoja MATRIZ, ordenando de forma descendente y seleccionando los “n” primeros casos.

Sub APTOS()
'Declaramos variables
Dim apto As Integer, pTotal As Integer
Dim j As Integer, rRango As Range, cCell As Variant
'Ordenamos la columna C descendente
With Sheets("MATRIZ")
pTotal = Application.CountA(Range("A:A"))
If pTotal > 1 Then .Range("D2:D" & pTotal).Clear
'elegimos a los n más aptos según % de seleccion
apto = Int((pTotal - 1) * .Cells(2, 9))
.Cells(1, 3) = "FITNESS"
Set rRango = Range("A1:E" & pTotal)
cCell = Range("C1")
rRango.Sort Key1:=cCell, Order1:=xlDescending, Header:=xlYes
For j = 2 To pTotal
If j - 1 <= apto Then
.Cells(j, 4) = .Cells(j, 2)
End If
Next j
'Volvemos a ordenar por la columna A
cCell = Range("A1")
rRango.Sort Key1:=cCell, Order1:=xlAscending, Header:=xlYes
End With
End Sub

Y el resultado es este:

GENERANDO UN ALGORITMO GENETICO EN VBA4

Finalmente, debemos generar una nueva población a partir de esos genes que hemos seleccionado. En este punto, hay muchas variantes y teorías de cómo hacerlo, en este caso, yo he elegido hacerlo de una forma particular aunque siempre podréis adaptarlo a vuestras necesidades o preferencias. Lo que se realiza en este paso es lo siguiente:

Los “n” casos aptos seleccionados los paso a una variable string (todos los cromosomas en una misma linea de datos), luego creo nuevos cromosomas a partir de esa cadena de forma aleatoria, menos el número final del nuevo cromosoma, es decir el número 10 lo vuelvo a elegir de otro subproceso aleatorio de números entre 1 y 9.

Este último paso nos va a ayudar a “regular” la diversidad genética, dado que podemos elegir que se generen números del 1 al 9 pero restringiendo el rango, por ejemplo, entre 1 y 2 o entre 1 y 3 etc … A mayor rango, mayor diversidad y esto permitirá que con cada generación existan más individuos diferentes entre si, esto se regula en NIVEL DE MUTACIÓN de hoja MATRIZ. La macro completa es esta:

Sub N_POBLACION()
'Declaramos variables
Dim scadena As String, x As String
Dim i As Integer, d As Integer, punto As Integer, nGen As Integer
Dim j As Integer, n As Integer, pTotal As Integer
'Seleccionamos los cromosomas más aptos
With Sheets("MATRIZ")
pTotal = Application.CountA(.Range("A:A"))
scadena = vbNullString
.Cells(1, 5) = "NUEVA POBLACIÓN"
'Y los pasamos a una cadena
For j = 2 To pTotal
scadena = scadena & .Cells(j, 4)
Next j
'Utilizamos cada número de la cadena
'para crear una cromosoma nuevo aleatoriamente

For i = 2 To pTotal
x = vbNullString
For n = 1 To Len(scadena)
punto = Application.WorksheetFunction.RandBetween(1, Len(scadena))
nGen = Application.WorksheetFunction.RandBetween(1, .Cells(2, 12))
d = Mid(scadena, punto, 1)
x = x & d
' Generamos un nuevo cromosoma con n-1 caracteres
' y el último lo volvemos a asignar aleatoriamente (nGen)

Q = .Cells(2, 11).Value
If Len(x) = Q - 1 Then Exit For
Next n
.Cells(i, 5) = x & nGen
Next i
End With
End Sub

Y este es el resultado:

GENERANDO UN ALGORITMO GENETICO EN VBA5

Dado que vamos a generar multitud de generaciones en cada cálculo, nos vendrá bien, pasar la información de cada cálculo a la hoja REPORT.Esto lo vamos a conseguir con esta macro situada al final de la macro INICIAL:

'Generamos informe resumen en la hoja REPORT
For i = 2 To pTotal
With Sheets("REPORT")
.Cells(i, 1) = Worksheets(1).Cells(i, 1)
.Cells(1, b + 1) = b & "ª" & " " & "GENERACION"
.Cells(i, b + 1) = Worksheets(1).Cells(i, 5)
.Cells(1, 1) = "Nº CASOS"
End With
Next i

De forma que tengamos un resumen de cada ejecución del programa con todas las generaciones que se han indicado. Y esta es la información resumen:

GENERANDO UN ALGORITMO GENETICO EN VBA7

En el resumen podemos apreciar la evolución de la primera generación hasta la quinta, en este ejemplo, aunque tenemos un nivel de mutación de 9, el % de selección es de 20% y por eso ya en la quinta generación todos los genes son muy parecidos. La clave está en jugar con el % de seleccionados para combinar y el nivel de mutación, cuando más altos más diversidad genética.

Como habéis podido observar, es un post bastante largo y con mucho contenido, útil para analizar el proceso y las técnicas utilizadas, y siempre teniendo en cuenta que esto es un ejemplo sencillo.

Para finalizar, me gustaría comentar sobre los controles de la hoja MATRIZ, aquellas celdas que están en azul son celdas en las que se muestra el cálculo, las celdas en gris son para que indiquéis los datos con los que queréis calcular:

GENERANDO UN ALGORITMO GENETICO EN VBA6

  • GENERACIONES: Son el número de veces que vamos a generar la aplicación. y que corresponden a las generaciones evolutivas de la población inicial.
  • SELECCIÓN: Es el % sobre el total que vamos a seleccionar los más aptos.
  • NÚMERO DE CASOS: Es el rango de casos, grabados de forma consecutiva, 1, 2 ,3 etc.
  • LONGITUD GENÉTICA: El largo o cantidad de números de cada cromosoma.
  • NIVEL MUTACIÓN: Introduce en el cálculo mayor o menor rango de números comprendidos entre 1 y 9. A mayor número mayor diversidad.

Y esto ha sido todo! ha sido un ejercicio completo y muy interesante!

Espero que os haya gustado y os pueda ser de utilidad 🙂

Descarga el archivo de ejemplo pulsando en: GENERANDO UN ALGORITMO GENÉTICO EN VBA

 

LISTAR TODOS LOS ARCHIVOS DE UNA CARPETA Y SUS SUBCARPETAS CON VBA

Hola a todos! Espero que todo vaya bien. 🙂

No tenía pensado escribir hoy un post, pero al final me he animado y aquí estoy!. El motivo de no querer postear es que llevo todo el fin de semana sumergido en los algoritmos genéticos y necesito un poco de descanso.

Pero como ya sabéis que trabajar en Excel para mi es una afición, pues no me ha costado demasiado decidirme.

Hoy vamos a tratar sobre la posibilidad de “listar” todo el contenido de archivos que podamos tener en una carpeta y sus subcarpetas. Listaremos cada archivo con el directorio completo y en formato hipervínculo, de manera que podamos luego buscar el archivo con solo pulsar el enlace.

Esta es una consulta que me llegó hace un año aproximadamente y hoy me he acordado de ella, así que os dejo la macro que le envié al lector como solución.

Como ejemplo me utilizaré a mi mismo. Como es obvio, todos los contenidos, macros, imágenes … etc, de esta web están almacenados en varias copias de seguridad, en varios equipos y también en la nube, imaginad que quiero listar todos los archivos que tengo en Excel Signum en uno de mis equipos, ¿cómo lo hago?.

Pues afortunadamente para mi, tengo esta macro que me ayudará con la tarea. En realidad una macro y una función, aquí os las dejo:

Sub LISTAR_ARCHIVOS()
'Declaramos variables
Dim sFSO As Object, Directorio As String
Dim dir_Archivo As Variant
'Abrimos ventana de diálogo para seleccionar carpeta
Set dir_Archivo = Application.FileDialog(msoFileDialogFolderPicker)
dir_Archivo.Show
'Si no seleccionamos nada salimos del proceso
If dir_Archivo.SelectedItems.Count = 0 Then
Exit Sub
End If
'Capturamos el directorio del archivo seleccionado
Directorio = dir_Archivo.SelectedItems(1)
'Creamos objeto y ejecutamos función Carpeta
Set sFSO = CreateObject("Scripting.FileSystemObject")
CARPETA sFSO.GetFolder(Directorio)
End Sub

Y esta es la función:

Function CARPETA(ByVal nCarpeta)
'Declaramos variables
Dim j As Long, Subcarpeta As Object
'Con la hoja activa
With ActiveSheet
'Limpiamos columna A si contiene datos
Fin = Application.CountA(ActiveSheet.Range("A:A"))
If Fin > 1 Then .Range("A2:A" & Fin).Clear
'Iniciamos dos loop, uno que recorre las carpetas
For Each Subcarpeta In nCarpeta.SubFolders
CARPETA Subcarpeta
Next
j = Application.CountA(.Range("A:A")) + 1
'y otro que recorre los archivos y los indexa y activa hipervínculo
For Each File In nCarpeta.Files
.Cells(j, 1).Select
.Hyperlinks.Add Anchor:=Selection, Address:=File.Path, TextToDisplay:=File.Path
j = j + 1
Next
End With
End Function

Una vez que pulsamos en la macro, nos aparecerá un cuadro de diálogo que nos va a permitir seleccionar la carpeta:

LISTAR TODOS LOS ARCHIVOS DE UNA CARPETA Y SUS SUBCARPETAS CON VBA

Una vez que pulsamos aceptar, entonces se comenzarán a listar todos los archivos en la hoja activa (en este caso la hoja1):

LISTAR TODOS LOS ARCHIVOS DE UNA CARPETA Y SUS SUBCARPETAS CON VBA1

Como podéis observar, esta es una muestra de los archivos de seguridad que tengo de Excel Signum y donde además hemos insertado en cada uno un hipervínculo con la ruta hasta el archivo real.

Se podría mostrar solo el nombre del archivo sin mostrar toda la ruta, simplemente se tendría que modificar TextToDisplay:=File.Path por TextToDisplay:=File.Name

Existen muchos tipos y formas de obtener estos datos con programación, esta es solo una forma, pero es la que suelo usar 🙂

Espero que os resulte útil, y me alegro de haber escrito finalmente el post.

Descarga el archivo de ejemplo pulsando en: LISTAR TODOS LOS ARCHIVOS DE UNA CARPETA Y SUS SUBCARPETAS CON VBA

 

EXTRAER REGISTROS ÚNICOS DE UN RANGO DE DATOS

Aunque normalmente no tengo mucho tiempo, a veces entro en algunos foros de Excel y contesto algunas de las preguntas que realizan los lectores. Esto es muy positivo, siempre encuentras nuevas ideas para desarrollar y hechas una mano a otras personas.

La última consulta que respondí iba sobre la posibilidad de extraer registros únicos pero no de una columna sino de un rango de datos. Es decir, seleccionar un rango de celdas y extraer los registros únicos.

Esta tarea se puede hacer de varias formas, en esta ocasión lo implementaré con matrices en VBA y finalmente aplicaremos quitar duplicados.

Como siempre vamos a usar un ejemplo: voy a pegar varias columnas (tres, por ejemplo) sobre las que seleccionaré el rango sobre el que extraer la información:

EXTRAER REGISTROS UNICOS DE UN RANGO DE DATOS1

A continuación debemos pegar la macro que realizará el trabajo:

Sub EXTRAER_UNICOS()
'Definimos variables
Dim i As Long, fin As Long
Dim rng As Range, celda As Range
Dim final As Long
Dim matriz() As Variant
'Desactivamos actualización de pantalla
Application.ScreenUpdating = False
'Trabajamos con la hoja activa
With ActiveSheet
'Limpiamos datos en la columna E
.Columns("E:E").ClearContents
'Capturamos selección y contamos registros
i = 1
Set rng = Selection
fin = rng.Count
'Redimensionamos la matriz
ReDim matriz(1 To fin)
'Con un loop grabamos los datos de cada celda
'y los pasamos a la columna E

For Each celda In rng
matriz(i) = celda.Value
i = i + 1
Next celda
For i = LBound(matriz) To UBound(matriz)
.Cells(i, 5) = matriz(i)
Next i
'Eliminamos duplicados de la columna E
final = .Cells(Rows.Count, "E").End(xlUp).Row
'Si no hay datos en la columna E salimos del proceso
If final = 1 Then Exit Sub
.Range("E1:E" & final).RemoveDuplicates Columns:=1, Header:=xlNo
'Ordenamos los datos, centrados y ascendentes
With .Columns("E:E")
.Select
.HorizontalAlignment = xlCenter
End With
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=Range("E1:E" & final), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With .Sort
.SetRange Range("E1:E" & final)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.Apply
End With
.Range("E1").Select
End With
Application.ScreenUpdating = True
End Sub

Ahora que ya tenemos la macro, solo tenemos que seleccionar los datos y pulsar en el botón de comando. El resultado lo pasará a la columna “E” o “5” (podéis especificar el destino que mejor se adapte a vuestras necesidades indicándolo en el código).

Y ya tenemos los datos:

EXTRAER REGISTROS UNICOS DE UN RANGO DE DATOS2

Dado que estamos trabajando con matrices, debéis tener en cuenta que tienen ciertos límites (por ejemplo, si seleccionamos toda la hoja, mostrará un error).

Y eso es todo por hoy, espero que os sea de utilidad. Por supuesto, en este ejemplo obtenemos los datos de una selección, pero se podría definir un rango perfectamente.

Descarga el archivo de ejemplo pulsando en: EXTRAER REGISTROS ÚNICOS DE UN RANGO DE DATOS