REALIZAR VARIAS CONSULTAS SQL CON ADO EN LA MISMA MACRO

Hola a todos!.

¿Qué tal os va?, espero que bien!. Hoy voy tratar el tema de las consultas SQL con ADO, en concreto voy a mostraros un método para poder realizar varias consultas SQL en una única macro.

Voy a partir de un post anterior para realizar el ejercicio: CRUZAR DOS TABLAS EN EXCEL USANDO SQL

En este post, mostraba la forma de realizar un cruce de dos bases de datos mediante consultas SQL usando ADO para obtener, altas, bajas, y movimientos entre los departamentos de unos grandes almacenes.

Si consultais las macros, veréis que hay cuatro en total, una para cada consulta. El motivo de hacerlo de esta forma es para se pueda comprender mejor la forma de usar ADO para quienes lo están empezando a programar y no me gusta complicar en exceso las programaciones dado que muchas veces, lo complicado en lugar de generar curiosidad, genera frustración.

Dicho esto, y una vez publicada la entrada anterior, ya puedo mostrar la forma de hacerlo en una única macro.

El código que vamos a utilizar es similar al ya utilizado, solo que vamos a escribir las cuatro sentencias SQL en el mismo código:

Sub GENERAR_CONSULTA()
Dim Dataread As ADODB.Recordset, obSQL As String
Dim cnn As ADODB.Connection, fin As Integer, milibro As String, i As Long
Dim alta As String, baja As String, alta_seccion As String, baja_seccion As String
Dim consulta As Variant, titulo As String
fin = Application.CountA(Sheets("MOVIMIENTOS").Range("A:A"))
'Borramos datos de consultas anteriores
Sheets("MOVIMIENTOS").Range("A2:D" & fin + 1).Clear
'indicamos los parámetros de las consultas que necesitamos:
'buscamos empleados nuevos
alta = "SELECT [BBDD_ACTUAL$].[ID], [BBDD_ACTUAL$].[NOMBRE COMPLETO], [BBDD_ACTUAL$].[SECCION], 'NUEVO EMPLEADO' AS ESTADO " & _
"FROM [BBDD_ACTUAL$] LEFT JOIN [BBDD_ANTERIOR$] ON [BBDD_ACTUAL$].[ID] = [BBDD_ANTERIOR$].[ID]" & _
"WHERE(([BBDD_ANTERIOR$].[ID]) IS NULL)"
'buscamos empleados que han sido baja
baja = "SELECT [BBDD_ANTERIOR$].[ID], [BBDD_ANTERIOR$].[NOMBRE COMPLETO], [BBDD_ANTERIOR$].[SECCION], 'BAJA' " & _
"FROM [BBDD_ANTERIOR$] LEFT JOIN [BBDD_ACTUAL$] ON [BBDD_ACTUAL$].[ID] = [BBDD_ANTERIOR$].[ID]" & _
"WHERE(([BBDD_ACTUAL$].[ID]) IS NULL)"
'buscamos movimientos de alta en departamento
alta_seccion = "SELECT [BBDD_ACTUAL$].[ID], [BBDD_ACTUAL$].[NOMBRE COMPLETO], [BBDD_ACTUAL$].[SECCION], 'ALTA SECCION' " & _
"FROM [BBDD_ACTUAL$] LEFT JOIN [BBDD_ANTERIOR$] ON [BBDD_ACTUAL$].[ID] = [BBDD_ANTERIOR$].[ID]" & _
"WHERE([BBDD_ACTUAL$].[SECCION]) NOT LIKE [BBDD_ANTERIOR$].[SECCION] "
'buscamos movimientos de baja en departamento
baja_seccion = "SELECT [BBDD_ANTERIOR$].[ID], [BBDD_ANTERIOR$].[NOMBRE COMPLETO], [BBDD_ANTERIOR$].[SECCION], 'BAJA SECCION' " & _
"FROM [BBDD_ACTUAL$] LEFT JOIN [BBDD_ANTERIOR$] ON [BBDD_ACTUAL$].[ID] = [BBDD_ANTERIOR$].[ID]" & _
"WHERE([BBDD_ANTERIOR$].[SECCION]) NOT LIKE [BBDD_ACTUAL$].[SECCION] "
'iniciamos loop por cada consulta SQL
For Each consulta In Array(alta, baja, alta_seccion, baja_seccion)
fin = Application.CountA(Sheets("MOVIMIENTOS").Range("A:A")) + 1
'Obtenemos el nombre del libro
milibro = ThisWorkbook.Name
'Creamos la conexión ADO
Set cnn = New ADODB.Connection
With cnn
.Provider = "Microsoft.ACE.OLEDB.12.0"
.ConnectionString = "DATA SOURCE=" & Application.ActiveWorkbook.Path + "\" & milibro
.Properties("Extended Properties") = "Excel 8.0"
.Open
End With
Set Dataread = New ADODB.Recordset
With Dataread
.Source = consulta
.ActiveConnection = cnn
.CursorLocation = adUseClient
.CursorType = adOpenForwardOnly
.LockType = adLockReadOnly
.Open
End With
'pasamos información a la hoja movimientos
Do Until Dataread.EOF
Dataread.MoveFirst
With Worksheets("MOVIMIENTOS")
.Cells(fin, 1).CopyFromRecordset Dataread
'Indicamos encabezados
For i = 0 To Dataread.Fields.Count - 1
titulo = Dataread.Fields(i).Name
.Cells(1, i + 1) = titulo
Next
.Cells(1, Dataread.Fields.Count) = "ESTADO"
End With
Loop
'ejecutamos la siguiente consulta
Next consulta
Set Dataread = Nothing
Set cnn = Nothing
End Sub

Como podéis observar, reducimos significativamente el tamaño de nuestro código y lo hacemos más eficiente y compacto. La clave está es crear un loop sobre el que iremos pasando cada una de las consultas SQL. Esto se consigue indicando el nombre de cada consulta en un array:

For Each consulta In Array(alta, baja, alta_seccion, baja_seccion)

El objeto “consulta” contendrá la secuencia SQL de cada consulta, lo que nos va a permitir pasar esos parámetros al recordset:

.Source = consulta

De esta forma en cada ciclo del loop tendremos el resultado de cada consulta, luego solo tenemos que pasar la información a la hoja movimientos y utilizar la variable “fin” para indicar el final de los datos de cada consulta y que se pueda mostrar el resultado en conjunto.

Una vez ejecutada la macro, tenemos el siguiente resultado, el mismo que el post del que estamos haciendo referencia.

REALIZAR VARIAS CONSULTAS SQL EN LA MISMA MACRO CON ADO

Y esto es todo, un método muy sencillo (dentro de la complejidad de ADO), que seguro os ayudará a realizar códigos más reducidos y eficientes.

Descarga el archivo de ejemplo pulsando en: REALIZAR VARIAS CONSULTAS SQL CON ADO EN LA MISMA MACRO

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

Donate Button with Credit Cards

¡¡Muchas gracias!!

Mediante la suscripción al blog, la realización comentarios o el uso del formulario de contacto estás dando tu consentimiento expreso al tratamiento de los datos personales proporcionados según lo dispuesto en la ley vigente (LOPD). Tienes más información al respecto en esta página del blog: Política de Privacidad y Cookies

Anuncios

INTRODUCIR MÚLTIPLES VALORES EN UN INPUTBOX

Hola a todos!.

Qué tal estáis? espero que bien! y supongo que muchos de vosotros ya estáis disfrutando de las vacaciones o esperando a que lleguen.

Hoy voy a comentar una solución que le ofrecí a un lector que me consultaba cómo podría introducir en un inputbox dos o más datos. Normalmente esta tarea se realiza con un formulario o userform, habilitando tantos cuadros de texto como sean necesarios.

Pero en el caso del inputbox solo tenemos un cuadro de texto, sin posibilidad de poder crear más cuadros de texto. Lo que nos obligaría a crear tantos inputbox como datos necesitemos introducir.

Pero existe una solución para poder introducir valores múltiples en un inputbox. Veamos un ejemplo, imaginad que queréis pasar dos fechas (Inicio y Fin) a través del mismo inputbox y mostrar los datos en las siguientes celdas:

INTRODUCIR MÚLTIPLES VALORES EN UN INPUTBOX

Para poder hacerlo, vamos a utilizar el siguiente código que he programado:

Sub INPUT_VARIOS()
'Declaramos las variables
Dim formulario, miarray
'Invocamos inputbox e indicamos las fechas separadas por una coma
formulario = InputBox("INDICA FECHA INICIO Y FECHA FIN SEPARADO POR UNA COMA:" & Chr(13) & Chr(13) & "EJEM: 01/01/2018,01/03/2018", "FECHAS")
'Si no ponemos nada, salimos del proceso
If formulario = Empty Then Exit Sub
'verificamos que los datos introducidos son correctos, si hay errores, los detectamos al final
On Error GoTo etiqueta
'Pasamos las dos fechas a una matriz utilizando la función split
miarray = Split(formulario, ",")
'Pasamos los datos a cada celda igualando los array
With Sheets("Hoja1")
.Cells(2, 1) = CDate(miarray(0))
.Cells(2, 2) = CDate(miarray(1))
End With
Exit Sub
etiqueta:
MsgBox ("Verifica los datos que has introducido e inténtalo de nuevo"), vbExclamation
End Sub

Al ejecutarlo veremos el siguiente inputbox en nuestra hoja:

INTRODUCIR MÚLTIPLES VALORES EN UN INPUTBOX_1

Como podéis observar en la macro, estamos utilizando la función split para pasar la información que hemos indicado en cuadro de texto del inputbox a una matriz. Como necesitamos indicar un elemento o carácter que separe las dos fechas (o cualquier otro dato), he decido utilizar la coma “,”aunque podríamos usar el punto y coma, “;” una arroba “@” etc, sustituyéndolo en la macro:

miarray = Split(formulario, ",")

Una vez que tenemos ambos datos, tan solo tendremos que pasar la información a las celdas de la hoja que necesitamos rellenar y lo hacemos pulsando en el botón aceptar de nuestro inputbox. Como cortesía hacia el lector, he programados varias líneas de código para controlar los datos erróneos o que surjan errores a la hora de ejecutar la macro.

El resultado es que tenemos en las celdas la información indicada en el cuadro de texto:

INTRODUCIR MÚLTIPLES VALORES EN UN INPUTBOX_2

Y eso es todo, como podéis observar sí es posible introducir valores múltiples en un inputbox.

Descarga el archivo de ejemplo pulsando en: INTRODUCIR MÚLTIPLES VALORES EN UN INPUTBOX

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

Donate Button with Credit Cards

¡¡Muchas gracias!!

Mediante la suscripción al blog, la realización comentarios o el uso del formulario de contacto estás dando tu consentimiento expreso al tratamiento de los datos personales proporcionados según lo dispuesto en la ley vigente (LOPD). Tienes más información al respecto en esta página del blog: Política de Privacidad y Cookies

EVITAR PANTALLA EN BLANCO Y MENSAJE “VBA NO RESPONDE” CUANDO EJECUTAMOS UNA RUTINA EN VBA

Hola a todos!

En algunas ocasiones , cuando programamos nuestras rutinas en VBA y el número de loops que realizamos es alto o se subdivide en varios procesos, cuando pulsamos en la nuestra hoja excel o en la pantalla del editor de VBA cuando se está ejecutando el código, se bloquea y se pone totalmente en blanco y muestra el mensaje de que VBA o Excel no responde.

Pero en realidad sí está ejecutando el código solo que no lo vemos, dado que excel muestra ese mensaje como consecuencia de la acumulación de eventos en nuestro procedimiento en ejecución.

Aunque seguro que hay otras formas de hacerlo, os voy a comentar la forma en la que suelo evitar esto cuando es necesario que el usuario o bien, pueda observar cómo se van desarrollando los diferentes pasos de la macro o bien, si no está familiarizado con VBA, no crea que el programa no funciona o no responde.

Hay que tener en cuenta que este mensaje también puede surgir cuando realmente existe un problema con el código (programación deficiente, loops infinitos, etc), para esos casos esta solución no será efectiva).

Voy a utilizar un código con algunos loops de diferente tipo, for – next y do – while los cuales nos van a venir perfectos. El código está en este post publicado sobre smartart: PROGRAMAR SMARTART PARA GENERAR UN DIAGRAMA DE GANTT

Dado que debemos actuar en los loops o bucles, lo que vamos a hacer es forzar a vaciar los eventos que se van acumulando. Esto lo vamos a lograr con esta sencilla línea de código:

If (Variable del loop) Mod (divisor) = 0 Then DoEvents

Aquí podéis profundizar un poco más sobre el operador MOD y su utilidad en este código. Lo utilizamos para condicionar el funcionamiento del método “doevents

Cuando el resultado de MOD, que es el residuo resultante de la división indicada en la condición sea igual a 0 entonces aplicamos doevents.

Esta condición, dependiendo del código, su estructura y variables, será necesario utilizarlo en diferentes parte de la macro. Normalmente en los bucles que resulten más lentos o extensos. Esto lo debéis ir verificando vosotros mismos cuando programéis vuestras rutinas.

En el ejemplo comentado, he incluido en tres ocasiones esta condición, lo resalto en rojo:

Sub DIAGRAMA_GANTT_SMARTART()
'Declaramos variables
Dim Diseño As SmartArtLayout
Dim Shape As Excel.Shape
Dim oNodos As SmartArtNodes
Dim inserta As Shape
Dim i As Integer, Fin As Integer
Dim j As Integer, valor As Double
Dim NPorcent As String, Per_2 As Long, Per_1 As Long
With Sheets("ESTRUCTURA")
.Select
'Eliminamos TODOS objetos en la hoja "ESTRUCTURA"
For Each Shape In .Shapes
Shape.Delete
Next

'Insertamos objeto SmartArt, en este caso "Jerarquía Multinivel"
Set Diseño = Application.SmartArtLayouts("urn:microsoft.com/office/officeart/2008/layout/HorizontalMultiLevelHierarchy")
Set inserta = .Shapes.AddSmartArt(Diseño)
Set oNodos = inserta.SmartArt.AllNodes
'Verificamos número de nodos necesarios contando los ítems de la página "DATOS"
Fin = Application.CountA(Sheets("DATOS").Range("A:A"))
'Creamos nodos
Do While oNodos.Count < Fin
oNodos.Add.Promote
'vaciamos eventos
If oNodos.Count Mod 2 = 0 Then DoEvents
Loop

'Eliminamos nodos sobrantes y los nombramos con la información de la hoja "DATOS"
For i = 2 To Fin
Do While oNodos(i - 1).Level < Sheets("DATOS").Range("B" & i).Value
oNodos(i - 1).Demote
Loop
'vaciamos eventos
If i Mod 2 = 0 Then DoEvents
Next
'Eliminamos último nodo (estará vacío al tener encabezado la hoja "DATOS")
oNodos(Fin).Delete
'aplicamos estilos
For Each Shape In .Shapes
'Colores
Shape.SmartArt.Color = Application.SmartArtColors("urn:microsoft.com/office/officeart/2005/8/colors/accent2_1")

'Estilos rápidos
Shape.SmartArt.QuickStyle = Application.SmartArtQuickStyles("urn:microsoft.com/office/officeart/2005/8/quickstyle/simple2")
'Iniciamos loop para recorrer el diagrama desde el último item al primero
For j = Fin To 2 Step -1
'Si el % está vacío, asignamos un valor 0 a la variable valor
If Sheets("DATOS").Range("F" & j).Value = Empty Then
valor = 0
ElseIf Sheets("DATOS").Range("F" & j).Value > 1 Then
valor = 1
Else
valor = Sheets("DATOS").Range("F" & j).Value
End If
'expresamos en color el porcentaje de cumplimiento de objetivos
With oNodos(j - 1).Shapes.Fill
.TwoColorGradient Style:=msoGradientVertical, Variant:=1
.GradientStops(2).Color = vbWhite
.GradientStops(1).Position = valor
.GradientStops(2).Position = valor
.GradientStops(1).Color.RGB = RGB(204, 204, 255)
End With

'Adicionalmente añadimos el porcentaje en número al diagrama y lo coloreamos en azul
With oNodos(j - 1)
.TextFrame2.TextRange.Text = Sheets("DATOS").Range("A" & j) & " " & Format(valor, "Percent")
NPorcent = Sheets("DATOS").Range("A" & j) & " " & Format(valor, "Percent")
Per_1 = UBound(Split(NPorcent)) + 1
Per_2 = UBound(Split(NPorcent)) + 2
.TextFrame2.TextRange.Words(Per_1).Font.Fill.ForeColor.RGB = vbBlue
.TextFrame2.TextRange.Words(Per_2).Font.Fill.ForeColor.RGB = vbBlue
End With
'vaciamos eventos
If j Mod 2 = 0 Then DoEvents
Next j
'Dimensionamos la imagen
With .Shapes(1)
.Height = 581.25 'Alto del objeto
.Width = 600.5 'Ancho del objeto
.Top = 100 ' Altura en la hoja
.Left = 14.25 ' A la izquierda de la hoja
End With
Next
End With
End Sub

El resultado es que además evitar que se congele nuestro proceso y por lo tanto el sistema nos diga que vba no responde, podemos ver cómo se desarrolla la macro en su totalidad.

Os he grabado un breve vídeo de la ejecución de esta macro para que veáis cómo funciona doevents:

Considero que no es necesario que os deje un archivo de prueba, creo que vosotros mismos podréis descargar del post anterior el código e introducir esta condición.

Os animo a realizar esta sencilla tarea para que comprobéis el cambio que se produce.

Y eso es todo, espero que facilite vuestros proyectos en VBA esta solución : )

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

Donate Button with Credit Cards

¡¡Muchas gracias!!

Mediante la suscripción al blog, la realización comentarios o el uso del formulario de contacto estás dando tu consentimiento expreso al tratamiento de los datos personales proporcionados según lo dispuesto en la ley vigente (LOPD). Tienes más información al respecto en esta página del blog: Política de Privacidad y Cookies

LISTAR LAS PROPIEDADES DE TODOS LOS ARCHIVOS DE UNA CARPETA Y SUBCARPETAS

Hola a todos!

Hace varios meses publiqué un post en el que trataba la forma de listar todos los archivos contenidos en una carpeta y subcarpetas: LISTAR TODOS LOS ARCHIVOS DE UNA CARPETA Y SUS SUBCARPETAS CON VBA

Hoy un lector me preguntaba la posibilidad de añadir a esta información la fecha de la última modificación en cada archivo listado. En realidad podemos obtener muchas más propiedades que nos pueden ser de utilidad según el tipo de necesidad que tengamos.

Para obtener lo que nos indica el lector, tan solo vamos a tener que realizar una pequeña modificación en la función original:

Function CARPETA(ByVal nCarpeta)
'Declaramos variables
Dim j As Long, Subcarpeta As Object
With ActiveSheet
'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 extrae propiedades
For Each file In nCarpeta.Files
.Cells(j, 1).Select
'fecha de creación
.Cells(j, 2) = file.DateCreated
'fecha de última modificación
.Cells(j, 3) = file.DateLastModified
'fecha del último acceso
.Cells(j, 4) = file.DateLastAccessed
'tipo de archivo
.Cells(j, 5) = file.Type
'tamaño
.Cells(j, 6) = file.Size
'por último activamos hipervínculo en el path del archivo
.Hyperlinks.Add Anchor:=Selection, Address:=file.Path, TextToDisplay:=file.Path
j = j + 1
Next
End With
End Function

Como podéis observar, utilizando el objeto file con el que anteriormente obtenemos su ruta, también podemos obtener una serie de propiedades, entre ellas la fecha de la última modificación DateLastModified

Pero también otras como el tipo de archivo, su tamaño, la fecha de creación y la del último acceso.

El resultado sería este:

LISTAR LAS PROPIEDADES DE TODOS LOS ARCHIVOS DE UNA CARPETA Y SUBCARPETAS

Así la consulta quedaría contestada y el lector ya tiene toda la información que necesita.

Y esto es todo!

Descarga el archivo de ejemplo pulsando en: LISTAR LAS PROPIEDADES DE TODOS LOS ARCHIVOS DE UNA CARPETA Y SUBCARPETAS

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

Donate Button with Credit Cards

¡¡Muchas gracias!!

Mediante la suscripción al blog, la realización comentarios o el uso del formulario de contacto estás dando tu consentimiento expreso al tratamiento de los datos personales proporcionados según lo dispuesto en la ley vigente (LOPD). Tienes más información al respecto en esta página del blog: Política de Privacidad y Cookies

SUMAR LA PARTE DECIMAL DEL CONTENIDO DE UN RANGO NUMÉRICO

Hola a todos!

Ayer tratábamos la forma de extraer  la parte entera de un número para realizar un sumatorio en un rango: SUMAR LA PARTE ENTERA DEL CONTENIDO DE UN RANGO CON NÚMEROS DECIMALES

Y tal como os comentaba, en la publicación de hoy me gustaría tratar la otra consulta que me habían enviado y que se refiere a la posibilidad de extraer la parte decimal de un número y proceder a su sumatorio, teniendo en cuenta también si es o no negativo.

Bien, para realizar esto os propongo crear una UDF (función definida por el usuario) que solucionará nuestro problema, veamos el ejemplo:

SUMAR LA PARTE DECIMAL DEL CONTENIDO DE UN RANGO NUMÉRICO

En la columna DATOS tenemos el número completo y en columna B la parte decimal (respetando si el número es negativo o positivo). En la última fila indicamos el sumatorio.

Esta tarea la podemos realizar con VBA creando una función específica. El código que vamos a usar es el siguiente:

Public Function SUMADECIMAL(ByVal miRango As Range) As Variant
'Definimos variables
Dim celda As Range, sCadena As Double
Dim matriz As Variant, nDec As Double
'Recorremos todas las celdas seleccionadas
For Each celda In miRango
'Si la celda contiene un decimal entonces
If celda <> Fix(celda) Then
'seleccionamos la parte decimal
matriz = Split(celda, ",")
'si el numero es menor que cero, entonces es negativo
If celda < 0 Then nDec = matriz(1) * -1
Else
'Si es mayor que cero entonces es positivo
If celda > 0 Then
nDec = matriz(1)
End If
End If
End If
'Sumamos cada decimal extraído
sCadena = sCadena + (nDec * 1)
nDec = 0
Next
'Mostramos el resultado en la función
SUMADECIMAL = Int(sCadena)
End Function

Básicamente, lo que hacemos es extraer de cada celda que no tenga un número entero su parte decimal. Controlando si es o no negativo ese número:

El resultado es el siguiente:

SUMAR LA PARTE DECIMAL DEL CONTENIDO DE UN RANGO NUMÉRICO1

Exactamente el mismo que mostraba más arriba.

Y esto es todo por hoy : )

Descarga el archivo de ejemplo pulsando en: SUMAR LA PARTE DECIMAL DEL CONTENIDO DE UN RANGO NUMÉRICO

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

Donate Button with Credit Cards

¡¡Muchas gracias!!

Mediante la suscripción al blog, la realización comentarios o el uso del formulario de contacto estás dando tu consentimiento expreso al tratamiento de los datos personales proporcionados según lo dispuesto en la ley vigente (LOPD). Tienes más información al respecto en esta página del blog: Política de Privacidad y Cookies

FUNCIÓN UNIR CADENAS EN EXCEL

Hola a todos!.

Con la versión office 365 y en concreto en Excel, Microsoft publicó en su momento algunas funciones nuevas que no se encuentran en otras versiones de Excel. Una de ellas es la función UnirCadenas. 

Esta función nos permite seleccionar un rango de celdas y pasar el contenido a una celda en modo cadena de texto. Su sintaxis es la siguiente:

UNIRCADENAS(delimitador, ignorar_vacío, Texto1, [Texto2],…)

Donde el delimitador puede ser un espacio en blanco, una coma, etc, y pudiendo evitar las celdas vacías en la composición de nuestro string.

El ejemplo sería este:

FUNCIÓN UNIR CADENAS EN EXCEL

Es decir, pasamos el rango de A2:A15 a una celda utilizando la fórmula. Sencillo, verdad?, así es.

Pero como siempre me gusta pensar en aquellos que no tienen el office 365 (por el motivo que sea), siempre podremos hacer lo mismo pero con VBA y construyendo nuestra propia función. Os la dejo aquí y luego explico:

Public Function UNECADENA(Delimitador As String, ignorar_vacio As Boolean, ByVal miRango As Range) As Variant
'Definimos variables
Dim celda As Range
Dim nCadena As String, sCadena As String
'Recorremos el rango y componemos string incluyendo el delimitador seleccionado e indicando si queremos incluir celdas vacías.
For Each celda In miRango
If ignorar_vacio = True And celda <> "" Then sCadena = sCadena & Delimitador & celda.Value
If ignorar_vacio = False Then sCadena = sCadena & Delimitador & celda.Value
Next
nCadena = Trim(Mid(sCadena, Len(Delimitador) + 1, Len(sCadena)))
UNECADENA = nCadena
End Function

Con esta UDF que acabo de programar podremos realizar el mismo trabajo que con la función UNIRCADENAS. La he denominado UNECADENA y funciona con la misma sintaxis que la función original:

Introducimos un delimitador, indicamos verdadero si queremos evitar las celdas vacías o falso si queremos que se tengan en cuenta y por último seleccionar el rango.

Aquí tenéis una prueba realizada con las dos funciones, utilizando el espacio como delimitador y teniendo en cuenta celdas vacías:

FUNCIÓN UNIR CADENAS EN EXCEL1

Y efectivamente, obtenemos el mismo resultado : )

Como habéis podido ver, mediante VBA hemos creado nuestra propia función para poder unir cadenas de forma sencilla.

Nota: He dejado la función Unircadenas en la hoja, si tenéis office 365 la veréis sin problema, pero si tenéis otra versión no se mostrará. En cualquier caso, la UDF que he creado la veréis en cualquier versión : )

Descarga el archivo de ejemplo pulsando en: FUNCIÓN UNIR CADENAS EN EXCEL

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

Donate Button with Credit Cards

¡¡Muchas gracias!!

Mediante la suscripción al blog, la realización comentarios o el uso del formulario de contacto estás dando tu consentimiento expreso al tratamiento de los datos personales proporcionados según lo dispuesto en la ley vigente (LOPD). Tienes más información al respecto en esta página del blog: Política de Privacidad y Cookies

EXTRAER PENÚLTIMA PALABRA EN UN TEXTO

Hola a todos!!

¿Qué tal estáis?. Espero que bien!. Hace tiempo que no escribo nada, pero llevo unas semanas con bastante lío y tengo poco tiempo para escribir nuevas entradas, porque además algunas consultas que me están llegando son bastante complejas y no se pueden trasladar al blog.

Pero hoy voy a responder a una bastante sencilla y que me ha permitido crear una función específica (en realidad dos funciones) para resolver el problema.

La consulta es: “Hola, me puedes decir cómo extraer la penúltima palabra de una celda excel? Gracias

Aunque es posible resolver esta cuestión recurriendo a una fórmula matricial, en mi opinión lo más eficiente es utilizar VBA y componer nuestra propia función personalizada. Vemos el ejemplo que voy a utilizar con un texto del que vamos a extraer la penúltima palabra.

El texto es un poema de Manoel Antonio, poeta gallego y uno de mis preferidos (y además era de Rianxo, muy cerca de Noia, mi pueblo natal). Está en su gallego original, se titula “Intencións”

EXTRAER PENÚLTIMA PALABRA EN UN TEXTO

Pues bien, para extraer la penúltima palabra vamos a recurrir a este código:

Function EXTRAE_PALABRA_DERECHA(ByVal Micelda, n As Integer)
'Declaramos variables
Dim sCadena As String, i As Integer, sCelda As String
Dim sCont As Integer, fin As Integer
'Añadimos espacio al inicio de la cadena de texto
sCelda = Space(1) & Micelda
fin = Len(sCelda)
'Recorremos cada caracter, si no es un espacio acumulamos hasta crear una palabra.
For i = fin To 1 Step -1
If (Mid(sCelda, i, 1)) <> " " Then
sCadena = sCadena & Mid(sCelda, i, 1)
'Si aparece un espacio, contamos (significa inicio de otra palabra)
Else
sCont = sCont + 1
'Si el contador es igual a "n" (la posición que queremos extraer) mostramos la palabra.
'Si no lo es vaciamos la variable
If sCont <> n Then sCadena = vbNullString
If sCont = n Then
EXTRAE_PALABRA_DERECHA = StrReverse(sCadena)
Exit Function
End If
End If
Next
End Function

El resultado es el siguiente:

EXTRAER PENÚLTIMA PALABRA EN UN TEXTO1

Como podéis observar solo tenéis que pegar el código en un módulo estándar y llamar a la función EXTRAE_PALABRA_DERECHA (podéis ponerle el nombre que más os guste modificando el código).

Los argumentos son =EXTRAE_PALABRA_DERECHA (Texto, letra a extraer desde la derecha), como empezamos por el final del texto, la penúltima letra será la 2, y la última la 1, y la antepenúltima la 3 …

Si queréis invertir la función y hacer lo mismo pero desde la izquierda, por ejemplo para extraer la segunda palabra, tendríamos que modificar sensiblemente el código:

Function EXTRAE_PALABRA_IZQUIERDA(ByVal Micelda, n As Integer)
Dim sCadena As String, i As Integer, sCelda As String
Dim sCont As Integer, fin As Integer
sCelda = Micelda & Space(1)
fin = Len(sCelda)
For i = 1 To fin Step 1
If (Mid(sCelda, i, 1)) <> " " Then
sCadena = sCadena & Mid(sCelda, i, 1)
Else
sCont = sCont + 1
If sCont <> n Then sCadena = vbNullString
If sCont = n Then
EXTRAE_PALABRA_IZQUIERDA = sCadena
Exit Function
End If
End If
Next
End Function

De esta forma, este sería el resultado de aplicar =EXTRAE_PALABRA_IZQUIERDA (A2;2)

EXTRAER PENÚLTIMA PALABRA EN UN TEXTO2

En el caso de las comas y otros caracteres, se podría implementar un control en el código para no tenerlas en cuenta, pero lo podéis solucionar con un sencillo reemplazar.

¿Os ha gustado?, seguro que sí y seguro que os resultará de mucha utilidad, porque os va a permitir poder extraer la palabra que queráis independientemente de la longitud del texto, (por la derecha o por la izquierda).

Descarga el archivo de ejemplo pulsando en: EXTRAER PENÚLTIMA PALABRA EN UN TEXTO

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

Donate Button with Credit Cards

¡¡Muchas gracias!!

Mediante la suscripción al blog, la realización comentarios o el uso del formulario de contacto estás dando tu consentimiento expreso al tratamiento de los datos personales proporcionados según lo dispuesto en la ley vigente (LOPD). Tienes más información al respecto en esta página del blog: Política de Privacidad y Cookies