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

Publicado el por

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

Anuncios

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

Publicado el por

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

ROMPER TODOS LOS VÍNCULOS CREADOS EN UN POWERPOINT

Publicado el por

Hola a todos:

Aunque esta web trata fundamentalmente sobre Excel, hoy voy a hacer una excepción para tratar un tema recurrente en el mundo de las presentación y los trabajos realizados entre Excel y PowerPoint.

En muchas ocasiones, las presentación que se realizan en PowerPoint utilizan objetos embebidos para mantener las vinculaciones de los datos que se generar desde otros programas, por ejemplo, desde Excel.

Os mostraré un sencillo ejemplo de cómo se realiza esta tarea, imaginad que tenemos este gráfico en una hoja excel:

ROMPER TODOS LOS VINCULOS CREADOS EN UN POWERPOINT

Si queremos que nuestra presentación de PowerPoint contenga este gráfico y se pueda actualizar automáticamente, no basta con cortar en Excel y pegar en Point, es necesario pegar de una forma especial:

ROMPER TODOS LOS VINCULOS CREADOS EN UN POWERPOINT1

Como podéis ver en la imagen, estamos pegando un vinculo con el pegado especial. De esta forma cualquier cambio que se produzca en Excel se reflejará en PPT:

ROMPER TODOS LOS VINCULOS CREADOS EN UN POWERPOINT2

Pero ¿qué sucede cuando queremos enviar esa presentación por correo?, pues que al abrirse en archivo nos va a preguntar si queremos actualizar los vínculos a, en este caso, el archivo de Excel. Para evitar que el usuario al que hemos enviado la presentación tenga que elegir si actualiza o no los vínculos, la única opción que tenemos es romperlos.

Para romper los vínculos a otros archivos en una presentación, tenemos tres opciones:

La primera opción consiste en pulsar en “Archivo” y luego en la opción “Información y buscar en la parte inferior derecha: “Editar vínculos a archivos”:

ROMPER TODOS LOS VINCULOS CREADOS EN UN POWERPOINT3

Una vez que pulsamos en esa opción se mostrará una ventana “vínculos” y solo tendremos que pulsar el botón “romper vínculo” para eliminar todas las vinculaciones a nuestra presentación.

La segunda opción es agregando el botón de “Romper vínculo” a la cinta de opciones. Para eso debemos ir a Archivo > Opciones > Personalizar cinta de Opciones y agregar Romper vínculo. El botón quedaría así:

ROMPER TODOS LOS VINCULOS CREADOS EN UN POWERPOINT4

Esta modalidad permite eliminar los vínculos sobre el objeto que seleccionemos, a diferencia del anterior que elimina todos los vínculos de la presentación.

Por último, os dejo otra forma, esta vez con VBA. Ejecutando este código en un módulo estándar de nuestra presentación eliminará todos los vínculos de la presentación:

Sub Romper_vinculos()
'Declaramos variables
Dim obj As Shape
Dim diapo As Slide
'Primer bucle recorremos todas las diapositivas
For Each diapo In ActivePresentation.Slides
'Segundo bucle recorremos todos los objetos de la diapo
For Each obj In diapo.Shapes
'si se trata de un objeto embebido eliminamos el link
If obj.Type = msoLinkedOLEObject Then
obj.LinkFormat.BreakLink
End If
Next obj
Next diapo
End Sub

Como es obvio, lo lógico es que esto lo hagamos sobre una copia de la presentación original, dado que de otra forma perderíamos las vinculaciones de nuestro trabajo.

Para este post no dejaré archivo dado que no es necesario y la información está dispuesta a modo de tutorial.

Espero que os haya resultado de interés : )

¿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

Publicado el por

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

SUMAR LA PARTE ENTERA DEL CONTENIDO DE UN RANGO CON NÚMEROS DECIMALES

Publicado el por

Hola a todos!:

Respondiendo a dos consultas, hoy publicaré la respuesta a la más sencilla de las dos y mañana intentaré responder a la segunda.

La pregunta que me trasladan es cómo se pueden sumar todos los enteros de un rango de números decimales. Por ejemplo este rango de números:

SUMAR LA PARTE ENTERA DEL CONTENIDO DE UN RANGO CON NÚMEROS DECIMALES

El resultado de esta suma es: -16,89539, pero a nosotros nos interesa la suma de sus enteros, es decir, 2 + 3 +4 + 6 etc donde el resultado debería ser 18

Para realizar el ejercicio con una fórmula y que contemple todo el rango podemos utilizar o bien una fórmula matricial o bien otra (que no deja de ser otra matricial pero muy especial).

Lo podemos hacer con está fórmula: {=SUMA(TRUNCAR(A2:A10))}  como ya sabéis  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

SUMAR LA PARTE ENTERA DEL CONTENIDO DE UN RANGO CON NÚMEROS DECIMALES2

Como podéis observar, realiza la suma correctamente y tan solo tenemos que combinar las funciones SUMA y TRUNCAR y activarlas matricialmente.

La segunda forma de hacerlo es utilizando la función sumaproducto combinada con la función TRUNCAR. No será necesario usar matrices ya que la función sumaproducto se expresa matricialmente:

SUMAR LA PARTE ENTERA DEL CONTENIDO DE UN RANGO CON NÚMEROS DECIMALES3

Y efectivamente aquí tenemos el mismo resultado.

Es importante diferenciar las funciones ENTERO y TRUNCAR, que aunque  parece que se obtiene el mismo resultado, la primera redondea con decimales y el resultado podría no ser preciso para esta tarea.

En el próximo post trataré de realizar la inversa, es decir, sumar la parte decimal de un número decimal : )

Descarga el archivo de ejemplo pulsando en: SUMAR LA PARTE ENTERA DEL CONTENIDO DE UN RANGO CON NÚMEROS DECIMALES

¿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

Publicado el por

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

Publicado el por

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