ELIMINAR DUPLICADOS DIRECTAMENTE SOBRE EL CONTENIDO DE UN LISTBOX

Hola a todos:

Ya sabéis que en esta web hay varias entradas que tratan el tema de los duplicados o cómo obtener registros únicos en nuestras informaciones, tanto en formularios como en bases de datos y usando métodos diferentes.

Sin embargo, esta semana un lector me solicitaba lo siguiente:

¿Es posible quitar los duplicados de un listbox mediante un boton
tomando los datos directamente del listbox sin tener que guardar la informacion a una hoja o tabla de calculo y que mantengan el mismo orden en el que fueron encontrados los registros por primera vez?

Es decir, interactuar directamente con el contenido del listbox sin posibilidad de acudir a la fuente de los datos y eliminar los duplicados antes de cargar la información en el listbox.

Aunque soy partidario de tratar la información antes de enviarla a un listbox (o combobox, etc…), lo cierto es que sí es posible hacer lo que el lector solicita. Y ese es el objetivo de este post.

Vamos a tomar un ejemplo en el que tenemos una base de datos con duplicados:

ELIMINAR DUPLICADOS DIRECTAMENTE SOBRE EL CONTENIDO DE UN LISTBOX

Estos datos los pasamos a un listbox en nuestro formulario y el código que utilizaremos para cargar el listbox es el siguiente:

Private Sub UserForm_Initialize()
Dim fin As Long
'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
With Sheets("BBDD")
fin = Application.CountA(.Range("A:A"))
Me.ListBox1.List = .Range("A2:G" & fin).Value
End With
End Sub

Es importante usar la propiedad listbox.list para cargar la información, dado que nos posibilitará el poder eliminar duplicados directamente en el listbox con el método RemoveItem.

ELIMINAR DUPLICADOS DIRECTAMENTE SOBRE EL CONTENIDO DE UN LISTBOX1

Podéis ver que nuestro listbox muestra todos los duplicados, pues bien, para eliminar los duplicados usaremos esta otra macro, vinculada al botón de comando “ELIMINAR DUPLICADOS”:

Private Sub CommandButton1_Click()
'Declaramos variables
Dim i As Long, j As Long
With ListBox1
'Eliminamos duplicados
For i = 0 To .ListCount - 1
For j = .ListCount - 1 To (i + 1) Step -1
If .List(j) = .List(i) Then .RemoveItem j
Next j
Next i
End With
End Sub

Una vez que hemos pulsado el botón, automáticamente se eliminan los duplicados en nuestro listbox, así:

ELIMINAR DUPLICADOS DIRECTAMENTE SOBRE EL CONTENIDO DE UN LISTBOX2

Pues bien, el utilizar la propiedad .list nos ha permitido solucionar este problema. Ahora ya tenemos nuestro listbox sin duplicados y listo para ser usado en otras tareas.

Espero que os haya resultado interesante y que os pueda ayudar en vuestros trabajos y proyectos.

Como siempre, os dejo el archivo de ejemplo : )

Descarga el archivo de ejemplo pulsando en: ELIMINAR DUPLICADOS DIRECTAMENTE SOBRE EL CONTENIDO DE 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!!

Anuncios

OBTENER DATOS A TRAVÉS DEL OBJETO WScript.Network Y OTRAS INFORMACIONES

Hola a todos!.

Recientemente recibí una consulta en la que un lector me preguntaba si le podía echar una mano  con una macro con la que deseaba extraer información de su equipo, en concreto necesitaba obtener el usuario de un equipo, el nombre del equipo, el nombre del dominio y la fecha y hora de la extracción de los datos.

Para poder conseguir los datos vamos a programar sobre el objeto WScript.Network, dado que sus propiedades (Username, UserDomain, ComputerName) nos van a permitir conocer los tres primeros datos.

De hecho, con esta simple macro obtendríamos la información:

Set sNetwork = CreateObject("WScript.Network")
nEqu = sNetwork.ComputerName
nDom = sNetwork.UserDomain
nUser = sNetwork.UserName

Efectivamente, creamos el objeto WScript.Networky a través de sus propiedades obtenemos la información que guaramos en tres variables.

Para obtener la fecha y la hora, podríamos usar la función Now en VBA, pero dado que estamos trabajando con scripts, lo haremos de la siguiente forma, con un objeto SWbemDateTime:

Set dtTime = CreateObject(“WbemScripting.SWbemDateTime”)
dtTime.SetVarDate (Now)
rDate = dtTime.GetVarDate

Y ya tendríamos los datos que el lector nos ha pedido. : )

El código completo sería así (con algunas cosas más que he añadido)

Sub INFORMACION_USUARIO()
'Declaramos variables
Dim sNetwork As Object, fSistem As Object, tSistem As Object, dir_Archivo As Object
Dim dtTime As Object, rDate As Date, i As Integer, MatrizInfo As Variant
Dim nEqu As String, nDom As String, nUser As String, Directorio As String
'Abrimos cuadro de dialogo 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
'Guardamos ruta a esta carpeta
Directorio = dir_Archivo.SelectedItems(1)
'Creamos objeto Network para obtener las propiedades de usuario, equipo y dominio
Set sNetwork = CreateObject("WScript.Network")
nEqu = sNetwork.ComputerName
nDom = sNetwork.UserDomain
nUser = sNetwork.UserName
'obtenemos la fecha y hora del sistema
Set dtTime = CreateObject("WbemScripting.SWbemDateTime")
dtTime.SetVarDate (Now)
rDate = dtTime.GetVarDate
'Creamos objeto filesistem para crear TXT
Set fSistem = CreateObject("Scripting.FileSystemObject")
Set tSistem = fSistem.CreateTextFile(Directorio & "\INFORMACION.txt", True)
'Pasamos los datos al TXT
tSistem.WriteLine "Nombre del equipo:" & nEqu
tSistem.WriteLine "Nombre del dominio:" & nDom
tSistem.WriteLine "Nombre del usuario:" & nUser
tSistem.WriteLine "Fecha y hora:" & rDate
'También pasamos los datos a la hoja
MatrizInfo = Array(nEqu, nDom, nUser, rDate)
For i = LBound(MatrizInfo) To UBound(MatrizInfo)
Sheets(1).Cells(i + 1, 1) = MatrizInfo(i)
Next i
'Vaciamos variable de objeto
Set sNetwork = Nothing
Set fSistem = Nothing
Set tSistem = Nothing
Set dir_Archivo = Nothing
Set dtTime = Nothing
End Sub

Me ha parecido interesante incluir un cuadro de diálogo para seleccionar un directorio en el que vamos a guardar en un TXT los datos extraídos:

El cuadro de diálogo y la extracción del directorio lo hacemos así:

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
'Guardamos ruta a esta carpeta
Directorio = dir_Archivo.SelectedItems(1)

y para crear el TXT y pasar los datos, usaremos el objeto FileSystemObject:

'Creamos objeto filesistem para crear TXT
Set fSistem = CreateObject("Scripting.FileSystemObject")
Set tSistem = fSistem.CreateTextFile(Directorio & "\INFORMACION.txt", True)
'Pasamos los datos al TXT
tSistem.WriteLine "Nombre del equipo:" & nEqu
tSistem.WriteLine "Nombre del dominio:" & nDom
tSistem.WriteLine "Nombre del usuario:" & nUser
tSistem.WriteLine "Fecha y hora:" & rDate

Una vez seleccionada la carpeta la macro creará el TXT (INFORMACION) y pasará la info, en mi caso la información es muy repetitiva, dado que siempre es la misma:

OBTENER DATOS A TRAVES DEL OBJETO WScript.Network Y OTRAS INFORMACIONES

Por último, he añadido los resultados en una matriz que luego pasamos a un loop para mostrar la información en la primera hoja de nuestro archivo, en la columna A:

MatrizInfo = Array(nEqu, nDom, nUser, rDate)
For i = LBound(MatrizInfo) To UBound(MatrizInfo)
Sheets(1).Cells(i + 1, 1) = MatrizInfo(i)
Next i

Y se mostraría así:

OBTENER DATOS A TRAVES DEL OBJETO WScript.Network Y OTRAS INFORMACIONES2

Aunque he incluido algunas cosas que el lector no pedía, creo que siempre es bueno incorporar herramientas nuevas o diferentes, de un modo o de otro, siempre nos podrían servir para otros proyectos.

Espero que os haya resultado de interés y os pueda ser de utilidad.

Descarga el archivo de ejemplo pulsando en:  OBTENER DATOS A TRAVES DEL OBJETO WScript.Network Y OTRAS INFORMACIONES

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

Donate Button with Credit Cards

¡¡Muchas gracias!!

BUSCAR VALORES CON EL MÉTODO RANGE.FIND EN EXCEL CON VBA

Hola a todos!.

¿Qué tal todo?, ¡espero que bien!.

Hoy voy a escribir acerca de un método interesante para buscar datos en Excel. Se trata del método range.find, que en comparación con otras funciones, se presenta mucho más rápido que un loop y ofrece mayor versatilidad que el uso de fórmulas.

Su uso es muy sencillo y ofrece unos resultados muy interesantes. Imaginad que tenemos en una hoja una dispersión de nombres de personas por diferentes celdas:

BUSCAR VALORES CON EL METODO RANGE.FIND EN EXCEL CON VBA

y estamos realizando una programación para obtener la localización del nombre que hemos seleccionado. Lo primero que se nos puede ocurrir es plantear un loop que recorra todas las celdas y vaya seleccionando el nombre que hemos elegido, sin embargo esto ocasionaría que nuestro código fuese demasiado lento (y sobre todo si ampliamos el tamaño del área que contiene la información).

La solución optima sería el uso del método range.find y que vamos a usar en el siguiente código:

Sub ENCONTRAR_DATO()
'Declaramos variables
Dim Dato As Range, cDato As String, nDato As String
Dim sLoc As String, nombre As String
With Sheets("DATOS").Cells
Sheets("RESULTADO").Cells(3, 2).ClearContents
'En la celda B2 indicamos el nombre a buscar
nombre = Sheets("RESULTADO").Cells(2, 1).Value
'Si el nombre está vacío salimos del proceso
If nombre = vbNullString Then Exit Sub
'Buscamos nombre (cualquier palabra o texto que lo contenga)
Set Dato = .Cells.Find(What:=nombre, lookat:=xlWhole)
'Si el nombre no existe, controlamos el error
On Error Resume Next
cDato = Dato.Address
On Error GoTo 0
'Si existe nombre entonces iniciamos un loop
If Not Dato Is Nothing Then
Do
'Que busca todas las coincidencias
Set Dato = .FindNext(Dato)
'En una cadena de texto grabamos la localización
'de las coincidencias
nDato = Dato.Address
sLoc = sLoc & " " & nDato
'Cuando la cDato sea igual a nDato
'salimos del loop
Loop Until cDato = nDato
End If
'pasamos los datos a celda B3
Sheets("RESULTADO").Cells(3, 1) = sLoc
End With
End Sub

Este código lo pegamos en un módulo estándar de nuestro editor VBA y en la hoja RESULTADO incluimos un botón de comando. El nombre a buscar lo escribimos en la celda A2 y ejecutamos la macro pulsando el botón.

En este caso, buscamos todos los nombres que se correspondan con “RAQUEL”, obteniendo el siguiente resultado:

BUSCAR VALORES CON EL METODO RANGE.FIND EN EXCEL CON VBA2

Es decir que existen dos resultados, ambos en las celdas J15 Y A14 respectivamente.

He dejado el dólar en el resultado, pero lo podéis eliminar usando un replace: replace(sloc,"$","")

Si comprobamos en la hoja DATOS podemos ver que el resultado es correcto:

BUSCAR VALORES CON EL METODO RANGE.FIND EN EXCEL CON VBA3.jpg

Y esto ha sido todo. Como podéis observar, se trata de un código sencillo y muy útil como alternativa al uso de loops que recorren grandes rangos.

Espero que os haya resultado de interés y os pueda ser de utilidad.

Descarga el archivo de ejemplo pulsando en:  BUSCAR VALORES CON EL MÉTODO RANGE.FIND EN EXCEL 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!!

CALCULAR UNA MATRIZ DE CORRELACIONES EN EXCEL CON VBA

Hola a todos:

Espero que hayáis tenido unas buenas fiestas!. Ahora que ya se acaban, es hora de volver a lo cotidiano y como no podía ser de otra manera, voy a escribir un sencillo post para mostrar cómo podemos calcular una matriz de correlaciones (aunque se podría utilizar para calcular otros estadísticos).

Para este trabajo me he descargado los datos de temperatura media durante el año 2015 en ciertos puntos de España (Fuente: INE). Aquí podéis ver la tabla de ejemplo que vamos a usar:

CALCULAR UNA MATRIZ DE CORRELACIONES EN EXCEL CON VBA

Es solo una muestra de algunos de los puntos de extracción de información climatológica, pero que nos va a servir perfectamente para realizar nuestro ejemplo.

A continuación,  en una hoja nueva, vamos a crear una matriz de 15 X 15 dado que son el total de elementos que tenemos:

CALCULAR UNA MATRIZ DE CORRELACIONES EN EXCEL CON VBA1

El siguiente paso es utilizar una sencilla UDF, para ayudarnos con el cálculo de las correlaciones, para ello, en un módulo estándar de nuestro editor de VBA insertáis este código:

Function Correlacion_matrix(rng As Range)
'Declaramos variables
Dim nColum As Long, i As Long, j As Long
Dim matrix As Variant
nColum = rng.Columns.Count - 1
'dimensionamos la matriz
ReDim matrix(nColum, nColum)
'Iniciamos loop para calcular matriz de correlaciones
For i = 0 To nColum
For j = 0 To nColum
matrix(i, j) = Application.WorksheetFunction.Correl(rng.Columns(i + 1), rng.Columns(j + 1))
Next j
Next i
'Pasamos resultado a la función
Correlacion_matrix = matrix
End Function

Ahora ya podemos utilizar esta función en nuestra hoja para realizar el cálculo matricial. Para introducir la función, debemos ir a la hoja MATRIZ y seleccionar el espacio que vamos a utilizar, es decir el rango B2:P16

CALCULAR UNA MATRIZ DE CORRELACIONES EN EXCEL CON VBA2.jpg

Y ahora, esto es importante, sin desmarcar el área seleccionada, os situáis en el espacio de fórmulas y escribís el nombre de la función: =Correlacion_matrix( y os posicionáis en la hoja DATOS, seleccionando el área que contiene los datos de temperatura, que es el rango B2:P13. Es decir, la fórmula quedaría así: =Correlacion_matrix(DATOS!B2:P13)

CALCULAR UNA MATRIZ DE CORRELACIONES EN EXCEL CON VBA3

Ahora que tenemos la fórmula completa, finalizamos la función seleccionando la fórmula y luego presionando CTRL + MAYUS + ENTRAR

El resultado es este:

CALCULAR UNA MATRIZ DE CORRELACIONES EN EXCEL CON VBA4

Como podéis observar, ya tenemos nuestra matriz de correlaciones entre las temperaturas medias mensuales durante el año 2015. Dado que las cifras hacen referencia a las temperaturas recogidas en el total de las estaciones, y estas son las mismas para todos los lugares con variaciones similares (no de la temperatura, sino de los incrementos y decrementos y su proporción), la correlación es alta. Las variaciones las debemos buscar en el segundo y tercer decimal, si bien, el dato a interpretar la correlación de la proporción de aumento o disminución de temperatura en el rango de tiempo seleccionado.

Obviamente, en la diagonal de la matriz siempre aparecerá una línea con un 1, que es donde se cruzan los datos del mismo lugar y la correlación es perfecta.

Y esto es todo por hoy, espero que os haya resultado de interés!!.
Descarga el archivo de ejemplo pulsando en: CALCULAR UNA MATRIZ DE CORRELACIONES EN EXCEL 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!!

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!!

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!!