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

REALIZAR BÚSQUEDAS DEPENDIENTES EN UN LISTBOX

Hola a todos : )

Hace unos días me enviaron una consulta en la que me solicitaban la necesidad de poder realizar consultas dependientes en un listbox.

Sobre el tema de las consultas dependientes, ya había tratado algo en esta entrada: COMBOBOX DEPENDIENTES EN USERFORM CON SQL , solo que esa ocasión estaba utilizando combobox.

En concreto, en esa consulta el filtro debería hacerse sobre un único listbox y utilizando varios textbox para indicar los items por los que realizar el filtrado.

Utilizará la base de datos de empleados de unos grandes almacenes (ya es un clásico en esta web) y pasaré los datos a un listbox:

Esta es la base de datos:

REALIZAR BUSQUEDAS DEPENDIENTES EN UN LISTBOX

Y mediante este código pasamos la información al listbox:

Private Sub UserForm_Initialize()
'Indicamos el número de columnas que tendrá el listbox
Me.ListBox1.ColumnCount = 7
'Definimos tamaño de los espacios
Me.ListBox1.ColumnWidths = "30pt;150pt;150pt;50pt;50pt;60pt"
'Cargamos listbox
Me.ListBox1.RowSource = ("A2:G") & Worksheets("BBDD").Range("A" & Rows.Count).End(xlUp).Row
End Sub

Aquí ya tenemos la información cargada:

REALIZAR BUSQUEDAS DEPENDIENTES EN UN LISTBOX2

Pero ahora debemos filtrar según nuestras necesidades. Para este ejemplo realizaré un secuencia de tres consultas dependientes: Primero filtramos por Sección, una vez tengamos esos datos, filtramos por Estudios y finalmente, filtraremos por Idioma.

Para ello es necesario crear tres textbox, y en cada uno de ellos realizar la programación correspondiente. Os dejo el código de cada textbox:

TextBox1 – Filtrar por Sección:

Private Sub TextBox1_Change()
'Declaramos variables
Dim fin As Long, i As Long, n As Long
Dim sCadena_seccion As String
'Filtramos por sección
With Sheets("BBDD")
fin = Application.CountA(.Range("A:A"))
If TextBox1 = "" Then
Me.ListBox1.RowSource = ("A2:G") & Worksheets("BBDD").Range("A" & Rows.Count).End(xlUp).Row
Exit Sub
End If
Me.TextBox2 = Clear
Me.TextBox3 = Clear
Me.ListBox1.RowSource = Clear
For i = 2 To fin
sCadena_seccion = .Cells(i, 3).Value
If UCase(sCadena_seccion) Like "*" & UCase(TextBox1.Value) & "*" Then
Me.ListBox1.AddItem
Me.ListBox1.List(n, 0) = .Cells(i, 1).Value
Me.ListBox1.List(n, 1) = .Cells(i, 2).Value
Me.ListBox1.List(n, 2) = .Cells(i, 3).Value
Me.ListBox1.List(n, 3) = .Cells(i, 4).Value
Me.ListBox1.List(n, 4) = .Cells(i, 5).Value
Me.ListBox1.List(n, 5) = .Cells(i, 6).Value
Me.ListBox1.List(n, 6) = .Cells(i, 7).Value
n = n + 1
End If
Next
Me.ListBox1.ColumnWidths = "30pt;150pt;150pt;50pt;50pt;60pt"
End With
End Sub

TextBox2 – Filtrar por Estudios:

Private Sub TextBox2_Change()
Dim fin As Long, i As Long, n As Long
Dim sCadena_seccion As String, sCadena_estudios As String
'Una vez filtrados los datos por sección, filtramos por estudios
With Sheets("BBDD")
fin = Application.CountA(.Range("A:A"))
If TextBox2 = "" Then
Me.ListBox1.RowSource = ("A2:G") & Worksheets("BBDD").Range("A" & Rows.Count).End(xlUp).Row
Exit Sub
End If
Me.ListBox1 = Clear
Me.ListBox1.RowSource = Clear
For i = 2 To fin
sCadena_seccion = .Cells(i, 3).Value
sCadena_estudios = .Cells(i, 7).Value
If UCase(sCadena_seccion) Like "*" & UCase(TextBox1.Value) & "*" And _
UCase(sCadena_estudios) Like "*" & UCase(TextBox2.Value) & "*" Then
Me.ListBox1.AddItem
Me.ListBox1.List(n, 0) = .Cells(i, 1).Value
Me.ListBox1.List(n, 1) = .Cells(i, 2).Value
Me.ListBox1.List(n, 2) = .Cells(i, 3).Value
Me.ListBox1.List(n, 3) = .Cells(i, 4).Value
Me.ListBox1.List(n, 4) = .Cells(i, 5).Value
Me.ListBox1.List(n, 5) = .Cells(i, 6).Value
Me.ListBox1.List(n, 6) = .Cells(i, 7).Value
n = n + 1
End If
Next
Me.ListBox1.ColumnWidths = "30pt;150pt;150pt;50pt;50pt;60pt"
End With
End Sub

TextBox3 – Filtrar por Idiomas:

Private Sub TextBox3_Change()
Dim fin As Long, i As Long, n As Long
Dim sCadena_seccion As String, sCadena_estudios As String, sCadena_idioma As String
'una vez filtrada la información por sección y estudios, filtramos por idioma

With Sheets("BBDD")

fin = Application.CountA(.Range("A:A"))
If TextBox2 = "" Then
Me.ListBox1.RowSource = ("A2:G") & Worksheets("BBDD").Range("A" & Rows.Count).End(xlUp).Row
Exit Sub
End If
Me.ListBox1 = Clear
Me.ListBox1.RowSource = Clear
For i = 2 To fin
sCadena_seccion = .Cells(i, 3).Value
sCadena_estudios = .Cells(i, 7).Value
sCadena_idioma = .Cells(i, 6).Value
If UCase(sCadena_seccion) Like "*" & UCase(TextBox1.Value) & "*" And _
UCase(sCadena_estudios) Like "*" & UCase(TextBox2.Value) & "*" And _
UCase(sCadena_idioma) Like "*" & UCase(TextBox3.Value) & "*" Then
Me.ListBox1.AddItem
Me.ListBox1.List(n, 0) = .Cells(i, 1).Value
Me.ListBox1.List(n, 1) = .Cells(i, 2).Value
Me.ListBox1.List(n, 2) = .Cells(i, 3).Value
Me.ListBox1.List(n, 3) = .Cells(i, 4).Value
Me.ListBox1.List(n, 4) = .Cells(i, 5).Value
Me.ListBox1.List(n, 5) = .Cells(i, 6).Value
Me.ListBox1.List(n, 6) = .Cells(i, 7).Value
n = n + 1
End If
Next
Me.ListBox1.ColumnWidths = "30pt;150pt;150pt;50pt;50pt;60pt"
End With
End Sub

Una vez te tenemos el código incluido en todos los controles, ya podemos proceder a probar la herramienta. Probaremos con la siguiente consulta: todos los empleados que pertenezcan a la sección de “Bricolaje“, que en sus estudios sean “Diplomados” y que sepan “Chino“.

El resultado es el siguiente:

REALIZAR BUSQUEDAS DEPENDIENTES EN UN LISTBOX3

Como podéis observar, el filtro funciona perfectamente y no es necesario escribir la palabra completa en los textbox, basta con ir escribiendo y la información se irá mostrando. En este caso tenemos a dos personas, perfecto!.

Y eso es todo, creo que es un método muy sencillo, donde trabajamos con un loop, un buscador y cargamos información si los parámetros de la consulta coinciden.

Espero que os resulte de interés : )

Descarga el archivo de ejemplo pulsando en: REALIZAR BÚSQUEDAS DEPENDIENTES EN UN LISTBOX

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

Donate Button with Credit Cards

¡¡Muchas gracias!!

CONTAR PALABRAS ESPECÍFICAS EN UNA CADENA DE TEXTO CON VBA

Hola a todos!

Esta temporada estoy bastante liado programando varios algoritmos de Inteligencia Artificial, y aunque es una programación bastante compleja, lo realmente complicado es poder dedicar tiempo a desarrollar estos códigos.

Pero aún así siempre tendré un momento para escribir nuevas publicaciones y compartirlas con todos vosotros.

En el post de hoy me gustaría mostrar un método para contar las veces que se repite una palabra específica en el una cadena de texto. Algo así como un “contar.si” pero con la diferencia que no estamos contando en un rango, sino en una variable string.

Partiendo de esta base, podemos hacerlo de varias formas, pero la de hoy en mi opinión sería la más eficiente, dado que evitamos utilizar bucles.

Para el ejemplo que os voy a poner empezaré desde el inicio, es decir, pasando los datos de un rango a una cadena de texto, esta sería la información de la hoja:

CONTAR PALABRAS ESPECIFICAS EN UNA CADENA DE TEXTO CON VBA

Se trata de la información sobre la presión arterial de varios pacientes de una clínica. Para el ejemplo utilizaremos la siguiente macro:

Sub CONTAR_STRING()
'Declaramos variable
Dim final As Long, i As Long
Dim sCadena As String, Contar As Long
'Trabajamos con la "Hoja1"
With Sheets("Hoja1")
final = Application.CountA(.Range("A:A"))
'Componemos cadena de texto
For i = 2 To final
ipalabra = ipalabra & "|" & .Cells(i, 2)
Next i
'Eliminamos espacio en blanco del inicio
sCadena = Trim(Mid(ipalabra, 2, Len(ipalabra)))
'Contamos el número de veces que se repite una palabra
Contar = UBound(Split(sCadena, "BAJA"))
End With
End Sub

sCadena será la variable a la que finalmente pasemos los datos de la cadena de texto, aquí podéis ver el contenido:

CONTAR PALABRAS ESPECIFICAS EN UNA CADENA DE TEXTO CON VBA1.jpg

Y ahora para contar las veces que se repite una palabra específica, por ejemplo “BAJA”, vamos a utilizar la siguiente línea de código:

Contar = UBound(Split(sCadena, "BAJA"))

y el resultado es que la palabra BAJA se repite 5 veces:

CONTAR PALABRAS ESPECIFICAS EN UNA CADENA DE TEXTO CON VBA2

Con una sola línea nos evitamos utilizar un loop y conseguimos mayor eficiencia en nuestros procesos.

Aunque este código es muy sencillo, este método de contar resulta muy interesante para grandes procesos o complejos algoritmos.

Y eso es todo, espero que os haya gustado!. En el archivo de prueba no hay botón de ejecutar, os dejo el código para que lo analicéis o probéis ejecutando la macro con “F8”.

Descarga el archivo de ejemplo pulsando en: CONTAR PALABRAS ESPECÍFICAS EN UNA CADENA DE TEXTO CON 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!!

OBTENER EL VALOR MÁXIMO Y MÍNIMO EN UNA MATRIZ

Hola a todos!

En el post de hoy voy a tratar un aspecto importante a la hora de trabajar con matrices, esto es, obtener el valor máximo o mínimo en un array (matriz).

No siempre trabajaremos con rangos, donde la obtención del valor máximo o mínimo es sencilla (utilizando las funciones MAX o MIN), muchas veces tenemos que utilizar matrices en nuestros procesos y en ocasiones debemos extraer ciertos valores.

Existen varias formas de hacer este trabajo, aunque hoy os mostraré la que yo suelo utilizar. Dependiendo de si la matriz nos viene creada o la debemos crear nosotros, el proceso será más o menos extenso.

Voy a suponer que tenemos los datos en una hoja Excel y debemos pasarlos a una matriz para luego determinar el valor mínimo y máximo de ese rango:

OBTENER EL VALOR MAXIMO Y MINIMO EN UNA MATRIZ

Ejecutando el siguiente código vamos a poder obtener los datos que necesitamos:

Sub OBTENER_MAX_MIN()
Dim rng As Range, fin As Long, celda As Variant
Dim sCadena As String, listMatriz As Object, nDato As Variant, nCadena As String
Dim oMatriz As Variant, n As Long, Min As Double, Max As Double
'Seleccionamos rango de números
Set rng = Selection
fin = rng.Count
'Controlamos que seleccionamos un rango de celdas con datos
If fin <= 1 Then Exit Sub
'Componemos una string con los valores seleccionados
For Each celda In rng
sCadena = Trim(sCadena) & " " & celda.Value
Next celda
'Pasamos los datos a una matriz (Lista)
Set listMatriz = CreateObject("System.Collections.ArrayList")
For Each nDato In Split(sCadena, " ")
listMatriz.Add nDato
Next nDato
'Ordenamos los datos
listMatriz.Sort
'Pasamos los datos a una cadena de texto
For Each nDato In listMatriz
nCadena = Trim(nCadena) & " " & nDato
Next nDato
'Convertimos el string en una matriz y con un loop extraemos valor mínimo y máximo
oMatriz = Split([nCadena], " ")
For n = LBound(oMatriz) To UBound(oMatriz)
If n = LBound(oMatriz) Then Min = oMatriz(n)
If n = UBound(oMatriz) Then Max = oMatriz(n)
Next
'Mostramos resultado en msgbox
MsgBox ("El valor mínimo es: " & Min & " y el valor máximo es: " & Max)
'Liberamos espacio en memoria
Set listMatriz = Nothing
End Sub

Lo verdaderamente importante de la macro es el método utilizado para obtener el valor máximo y mínimo. Es decir, componemos un array:

'Pasamos los datos a una matriz (Lista)
Set listMatriz = CreateObject("System.Collections.ArrayList")
For Each nDato In Split(sCadena, " ")
listMatriz.Add nDato

Next nDato

y ordenamos los datos:

listMatriz.Sort

A continuación volvemos a pasar la información a una cadena de texto con los datos ordenados:

'Pasamos los datos a una cadena de texto
For Each nDato In listMatriz
nCadena = Trim(nCadena) & " " & nDato
Next nDato

En este punto, la información que tenemos es una cadena de texto totalmente ordenada, aquí lo podéis ver mostrando el contenido de la variable nCadena:

OBTENER EL VALOR MAXIMO Y MINIMO EN UNA MATRIZ1

Con esta información, ahora ya podemos obtener los datos que estamos buscando. Dado que sabemos que el primer valor de la cadena es el mínimo y el último el máximo, solo tenemos extraer esa información.

Esto lo podemos hacer de varias formas, pero dado que estamos trabajando con matrices, esta es la solución que voy a utilizar. Pasamos los datos de nuevo a una matriz y mediante un bucle “for-next” y con las funciones LBound y UBound que determinan el inicio de la matriz (siempre es 0) y el final, (en este caso 60, dado que son 60 elementos seleccionados), podemos detectar con un condicional cuando “n” es igual a LBound o “0” y obtendremos el mínimo, y de la misma forma, cuando “n” es igual a UBound obtendremos el máximo valor:

oMatriz = Split([nCadena], " ")
For n = LBound(oMatriz) To UBound(oMatriz)
If n = LBound(oMatriz) Then Min = oMatriz(n)
If n = UBound(oMatriz) Then Max = oMatriz(n)
Next

Como habéis podido observar, ya hemos conseguido la información que necesitábamos. Ahora podemos incluir esta información en nuestros procesos o cálculos dado que está contenida en ambas variables (Min y Max).

Para que veáis el resultado de la macro, he pasado los resultados a un msgbox para ver de manera informativa los datos:

OBTENER EL VALOR MAXIMO Y MINIMO EN UNA MATRIZ2

Aunque debería haber utilizado directamente un matriz, sin hacer referencia a la hoja ni al rango seleccionado, creo que de esta forma se ilustra mejor el ejemplo.

Y esto es todo, espero que esta metodología os ayude en vuestros procesos.

Descarga el archivo de ejemplo pulsando en: OBTENER EL VALOR MÁXIMO Y MÍNIMO EN UNA MATRIZ

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

Donate Button with Credit Cards

¡¡Muchas gracias!!

SUMAR EL VALOR DE CADA N NÚMEROS EN UN RANGO

Hola a todos!

Hoy de nuevo voy a escribir sobre funciones matriciales, en el post de hoy veremos cómo podemos sumar el valor de cada “n” números en un rango.

Creo que la mejor forma de explicar esto se puede hacer con una imagen:

SUMAR CADA N VALOR EN UN RANGO

Imaginad que tenemos que hallar el resultado de cada cuatro números en la columna A, (adicionalmente en la columna B he colocado estos números para ofrecer un ejemplo más claro. El resultado sería de 40.

Para realizar esta operación con una sola fórmula o bien recurrimos a macros o bien utilizamos fórmulas matriciales. En el ejemplo de hoy utilizaré una fórmula matricial:

{=SUMA(SI(RESIDUO(FILA(INDIRECTO("1:"&CONTAR(A:A)));4)=0;DESREF(A2;0;0;COINCIDIR(9,99999999999999E+307;A:A)-FILA(A2)+1;1);""))}

Una vez aplicada, el resultado es el de 40:

SUMAR CADA N VALOR EN UN RANGO1

Con esta fórmula somos capaces de obtener los “n” valores que decidamos dentro de un rango variable y proceder a su suma. En rojo está el número que os servirá para indicar el “n” valor, en este ejemplo, el 4.

Os recuerdo que las matrices se introducen: seleccionando la celda que contiene la fórmula, pulsando en F2 , seleccionamos la fórmula y luego presionamos CTRL + MAYUS + ENTRAR

Y esto a ha sido todo, espero que os resulte de interés.

Descarga el archivo de ejemplo pulsando en: SUMAR EL VALOR DE CADA N NÚMEROS EN UN RANGO

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

Donate Button with Credit Cards

¡¡Muchas gracias!!

CONTAR NÚMERO DE CARACTERES EN UN RANGO UTILIZANDO FÓRMULAS

Hola a todos!

En el post de hoy voy a trabajar con fórmulas, no siempre vamos a utilizar macros cuando la solución la podemos hallar mediante funciones nativas de Excel.

Un lector me preguntaba ayer si podía ofrecerle una fórmula que contase el número total de caracteres contenidos en un rango de celdas. Aunque podéis pensar que una sencilla solución es usar la función LARGO aplicada a cada celda y luego sumar el total, la respuesta se puede lograr usando una única fórmula (pero matricialmente).

Pero para ilustrar el ejemplo, imaginad que queremos obtener el total de caracteres que contiene el siguiente fragmento de archivo XML obtenido como respuesta a una consulta realizada a Google Maps:

CONTAR NUMERO DE CARACTERES EN UN RANGO UTILIZANDO FORMULAS

Para obtener el total de caracteres de toda la columna A utilizaremos la siguiente fórmula:

{=SUMA(LARGO(A:A))}

El resultado obtenido va a tener en cuenta cualquier caracter, incluidos los espacios en blanco, las comas, los puntos, etc. En concreto, el resultado es de 1720 caracteres.

Con esto el lector ya tiene la respuesta a su consulta, sin embargo, imaginad que lo que necesita es conocer solo el número de caracteres alfanuméricos. Es decir sin tener en cuenta los espacios, puntos, comas …

Para poder realizar el mismo ejercicio, necesitamos incluir la función SUSTITUIR en nuestra función inicial y además anidando los elementos que queremos excluir en la cuenta final:

{=SUMA(LARGO(SUSTITUIR(SUSTITUIR(SUSTITUIR(SUSTITUIR(SUSTITUIR(SUSTITUIR(A:A;">";"");"<";"");"/";"");" ";"");"_";"");".";"")))}

Aplicando esta fórmula el resultado ahora es de 1176 caracteres, como podéis observar el número se ha reducido significativamente.

CONTAR NUMERO DE CARACTERES EN UN RANGO UTILIZANDO FORMULAS1

Os recuerdo que las matrices se introducen: seleccionando la celda que contiene la fórmula, pulsando en F2 , seleccionamos la fórmula y luego presionamos CTRL + MAYUS + ENTRAR

Espero que os resulte de utilidad!

Descarga el archivo de ejemplo pulsando en: CONTAR NUMERO DE CARACTERES EN UN RANGO UTILIZANDO FORMULAS

 

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

Donate Button with Credit Cards

¡¡Muchas gracias!!

EXTRAER DATOS DE UNA CELDA Y COLOCARLOS EN DIAGONAL

Hola a todos : )

Este fin de semana he tenido que resolver dos consultas bastante complicadas que me enviaron unos lectores y no tuve tiempo para subir el post que había preparado. Pero hoy ya puedo hacerlo : )

La entrada de hoy se basa en una consulta que me enviaron hace unas semanas, aunque se trata de una tarea sencilla, realmente no sé cual es el destino o función para la que se necesita. En la petición se solicitaba una macro que extrajera el contenido de una celda (letras o números) y que colocase los datos en diagonal.

Intuyo que se trata de algo para generar claves o correspondencias, pero bueno … yo me he limitado a enviar el código según sus especificaciones.

Imaginad estos datos:

EXTRAER DATOS DE UNA CELDA Y COLOCARLOS EN DIAGONAL

y ahora tenemos que colocar cada letra o número de la palabra en diagonal, ¿cómo lo hacemos?, pues con esta macro:

Sub PASAR_A_DIAGONAL()
'Declaramos variables
Dim i As Long, j As Long
Dim fin As Long, n As Long
'Desactivamos actualización de pantalla
Application.ScreenUpdating = False
With Sheets("Hoja1")
'Eliminamos datos anteriores
If .Range("B2").Value <> vbNullString Then
.Range("B2", ActiveCell.SpecialCells(xlLastCell)).Select
Selection.ClearContents
End If
'Iniciamos loop que recorra todas las celdas
fin = Application.CountA(.Range("A:A"))
For i = 2 To fin
miCelda = .Cells(i, 1)
n = Application.CountA(.Range("B:B")) + 2
'Iniciamos loop que recorra toda la palabra
'y colocamos números o letras en diagonal
For j = 1 To Len(miCelda) Step 1
Letra = Mid(miCelda, j, 1)
.Cells(n, j + 1) = Letra
.Cells(n, j + 1).HorizontalAlignment = xlRight
n = n + 1
Next j
n = 0
Next i
.Range("A1").Select
Application.ScreenUpdating = True
End With
End Sub

Como podéis observar, básicamente utilizamos dos loop para localizar y extraer los datos. Luego solo tenemos que utilizar las variables creadas para indicar el lugar (horizontal y vertical) en que se debemos mostrar la información.

El resultado de aplicar la macro es este:

EXTRAER DATOS DE UNA CELDA Y COLOCARLOS EN DIAGONAL1

Efectivamente, los datos se han ordenado en diagonal, tanto las letras como los números. Sin duda una petición curiosa : )

Y esto ha sido todo por hoy, espero que os resulte interesante.

Descarga el archivo de ejemplo pulsando en: EXTRAER DATOS DE UNA CELDA Y COLOCARLOS EN DIAGONAL

 

 

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

Donate Button with Credit Cards

¡¡Muchas gracias!!