ELIMINAR FILAS VACÍAS SI TODAS LAS CELDAS DEL RANGO ESTÁN EN BLANCO PARTE II

Hola a todos!:

Este post es continuación del anterior: ELIMINAR FILAS VACÍAS SI TODAS LAS CELDAS DEL RANGO ESTÁN EN BLANCO , en el que utilizábamos un ciclo “Do Until”  para eliminar filas en blanco cuando toda la fila (o el rango indicado) estuviese vacía.

Un lector me indicó que sería más sencillo de utilizar un For – Next, dado que era una estructura de programación más fácil de comprender en su funcionamiento. Bien, esto usualmente es así y los procedimientos for – next resultan más sencillos de comprender que los loop tipo: Do While o Do Until.

En este caso, creo que aporta información útil para todos nosotros y he decidido publicarlo. He variado la base de datos para que no sea siempre la misma y he utilizado una hoja de varios miles de registros para el ejemplo:

ELIMINAR FILAS VACÍAS SI TODAS LAS CELDAS DEL RANGO ESTÁN EN BLANCO PARTE II

Vamos a usar la siguiente rutina para realizar el ejercicio de eliminar filas en blanco, solo tendréis que añadir varias filas en blanco y ejecutar el código.

Option Explicit
Sub ELIMINAR_FILAS_VACIAS()
'Declaramos variables
Dim mirango As Object
Dim i As Long
With ActiveSheet
'Contamos hasta la última celda con datos
For i = 1 To .Cells(Rows.Count, 1).End(xlUp).Row
'Si la fila está vacía comenzamos el proceso
If .Application.CountA(Range(i & ":" & i)) = 0 Then
'Si el rango está vacío guardamos primera fila vacía
If mirango Is Nothing Then
Set mirango = Rows(i)
Else
'Si no está vacío utilizamos función Unión()
Set mirango = Union(mirango, Rows(i))
End If
End If
Next i
'Eliminamos contenido de mirango
If Not mirango Is Nothing Then mirango.Delete
End With
'cerramos variable
Set mirango = Nothing: Close
End Sub

El resultado será que la macro va a eliminar la fila o filas vacías en el rango indicado.

Y eso es todo, espero que os haya resultado interesante!.

Descarga el archivo de ejemplo pulsando en: ELIMINAR FILAS VACÍAS SI TODAS LAS CELDAS DEL RANGO ESTÁN EN BLANCO_II

¿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

PROGRAMAR MÉTODO POPUP DE VBSCRIPT

Hola a todos:

Hace unos días en LinkedIn os comenté una alternativa a la función MsgBox() en vba a la hora de mostrar una ventana emergente. Esta alternativa es el método Popup de VBScript.

Es muy sencillo de programar!. Vemos de qué argumentos se compone utilizando un ejemplo:

mensaje= MiObjShell.PopUp(Texto,[Tiempo de espera en segundos],[Titulo de la ventana (opcional)],[Tipo (opcional)])

El primer argumento es el que hace referencia al texto de contenido del PopUp.

El segundo argumento es el tiempo en espera y que se expresa en segundos. Indicaremos aquí el tiempo que queremos que se muestre la información.

El tercer argumento es el título de la ventana del PopUp, es opcional, si no ponemos nada por defecto se mostrará “Windows Script Host”.

El cuarto argumento que también es opcional nos va a permitir mostrar un icono y el tipo de botones que queremos que se muestren en nuestro PopUp:

Iconos:

16 – Stop (o vbCritical)
32 – Interrogante (o vbQuestion)
48 – Exclamación (o vbExclamation)
64 – Información (o vbInformation)

Tipo de botones:

0 – Aceptar (o vbOKOnly)
1-  Aceptar/Cancelar (o vbOkCancel)
2- Anular/Reintentar/Omitir (o vbAbortRetryIgnore)
3- Si/No/Cancelar (o vbYesNoCancel)
4- Si/No (o vbYesNo)
5- Reintentar/Cancelar (o vbRetryCancel)
6- Cancelar/Reintentar/Continuar

Por ejemplo, aquí lo programo con un Set:

Mostramos el mensaje “DESEAS MOSTRAR LA INFORMACIÓN?” que debe mostrarse durante 1 segundo y mostramos el icono de la interrogación y los botones Si/No

Sub PopUp()
Dim MiObjShell As Object
Dim imensaje As Long
Set MiObjShell = CreateObject("wscript.shell")
imensaje = MiObjShell.PopUp("DESEAS MOSTRAR LA INFORMACIÓN?", 1, "MI VENTANA", 32 + 4)
End Sub

Podríamos ejecutar el mensaje varias veces para que veais que cada segundo (aprox) cambia automáticamente de mensaje hasta que finaliza la rutina:

Sub PopUp()
Dim MiObjShell As Object
Dim imensaje As Long
Set MiObjShell = CreateObject("wscript.shell")
imensaje1 = MiObjShell.PopUp("DESEAS MOSTRAR LA INFORMACIÓN?", 1, "MI VENTANA", 32 + 4)
imensaje2 = MiObjShell.PopUp("DESEAS MOSTRAR LA INFORMACIÓN?", 1, "MI VENTANA", vbInformation + vbAbortRetryIgnore)
imensaje3 = MiObjShell.PopUp("DESEAS MOSTRAR LA INFORMACIÓN?", 1, "MI VENTANA", vbCritical + 6)
imensaje4 = MiObjShell.PopUp("DESEAS MOSTRAR LA INFORMACIÓN?", 1, "MI VENTANA", vbExclamation + 2)
End Sub

Estos serían los PopUp’s generados:

imensaje = MiObjShell.PopUp("DESEAS MOSTRAR LA INFORMACIÓN?", 1, "MI VENTANA", 32 + 4)

PROGRAMAR MÉTODO POPUP DE VBSCRIPT

imensaje = MiObjShell.PopUp("DESEAS MOSTRAR LA INFORMACIÓN?", 1, "MI VENTANA", vbInformation + vbAbortRetryIgnore)

PROGRAMAR MÉTODO POPUP DE VBSCRIPT_1

imensaje = MiObjShell.PopUp("DESEAS MOSTRAR LA INFORMACIÓN?", 1, "MI VENTANA", vbCritical + 6)

PROGRAMAR MÉTODO POPUP DE VBSCRIPT_2

imensaje = MiObjShell.PopUp("DESEAS MOSTRAR LA INFORMACIÓN?", 1, "MI VENTANA", vbExclamation + 2)

PROGRAMAR MÉTODO POPUP DE VBSCRIPT_3

Como podéis observar son una buena alternativa a los MsgBox que todos solemos utilizar, solo que con alguna funcionalidad más.

Y eso es todo, espero que os haya resultado interesante y lo podáis implementar en vuestras programación y proyectos.

Descarga el archivo de ejemplo pulsando en: PROGRAMAR MÉTODO POPUP DE VBSCRIPT

¿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

ELIMINAR FILAS VACÍAS SI TODAS LAS CELDAS DEL RANGO ESTÁN EN BLANCO

Hola a todos!

En el post de hoy voy a responder a un lector la siguiente consulta relacionada con este antiguo post: ELIMINAR FILAS VACÍAS CON VBA EN EXCEL

Esta es la consulta: “Gracias por Compartir. Está excelente. La ejecuté y funciona perfecto para rangos cuyas filas vacías están definidas desde la columna “A”. Pero, ¿cómo hacer para eliminar filas vacías cuando en un rango, por ejemplo desde Columna A hasta Columna BH, tengo columnas que contienen datos, es decir no están “totalmente vacías”, es decir quiero eliminar sólo Filas “totalmente vacías”.
Nuevamente, Gracias! y feliz 2020!”

Os propongo el siguiente código:

Option Explicit
Sub ELIMINAR_FILAS_VACIAS()
'Declaramos variables
Dim r As Long
Dim Control As Long
With ActiveSheet
'Iniciamos loop
r = 1
Do Until r = .Cells(Rows.Count, 1).End(xlUp).Row
Control = Application.CountA(.Range(Cells(r, 1).Row & ":" & Cells(r, 1).Row))
'Control = Application.CountA(.Range("A" & Cells(d, 1).Row & ":" & "BH" & Cells(d, 1).Row))
'Si variable control es 0 entonces eliminamos fila
If Control = 0 Then
Rows(r).Delete
Else
'Si no es 0 seguimos con la fila siguiente
r = r + 1
End If
Loop
End With
End Sub

En esencia utilizamos un loop do – until para eliminar las filas.

Por ejemplo, tenemos este listado, en verde he marcado las filas que debe desaparecer:

ELIMINAR FILAS VACÍAS SI TODAS LAS CELDAS DEL RANGO ESTÁN EN BLANCO

Y este es el resultado:

ELIMINAR FILAS VACÍAS SI TODAS LAS CELDAS DEL RANGO ESTÁN EN BLANCO_1

Y eso es todo, espero que la respuesta sea de utilidad!.

Descarga el archivo de ejemplo pulsando en: ELIMINAR FILAS VACÍAS SI TODAS LAS CELDAS DEL RANGO ESTÁN EN BLANCO

¿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 PARA EXTRAER REGISTROS ÚNICOS DE UN RANGO

Hola a todos!.

Qué tal estáis? supongo que disfrutando de los últimos días del año!.

Hoy os voy a dejar un código para crear una UDF que sea capaz de extraer los registros únicos de un rango determinado. Aunque ya os había propuesto una macro parecida aquí: EXTRAER REGISTROS ÚNICOS DE UN RANGO DE DATOS

En este código lo vamos a hacer con una función y utilizando un método distinto. La principal diferencia es que el resultado de la función lo vamos a llevar a una celda y no de nuevo a un rango.

Veamos el código:

Option Explicit
Function UNICOS(ByVal Target As Range, delimitador As String)
'Declaramos variables
Dim oDic As Object
Dim Micelda As String, matrix1 As Variant
Dim i As Long, Unico As String, celda As Variant
With Sheets("Hoja1")
'Creamos objeto diccionario
Set oDic = CreateObject("scripting.dictionary")
'Componemos string con el rango seleccionado
For Each celda In Target
If celda <> vbNullString Then
Micelda = Micelda & delimitador & celda
matrix1 = Split(Micelda, delimitador)
End If
Next celda
'Eliminamos números o letras repetidos
For i = 0 To UBound(matrix1)
If Not oDic.Exists(matrix1(i)) Then oDic.Add matrix1(i), matrix1(i)
Next i
'Extraemos registros únicos con el delimitar elegido
Unico = Mid(Join(oDic.keys, delimitador), Len(delimitador) + 1, Len(Join(oDic.keys, delimitador)))
UNICOS = Unico
End With
'Vaciamos variable de objeto
Set oDic = Nothing
End Function

¿Que resultado conseguimos con este código?, pues este:

Primero seleccionamos el rango e indicamos el delimitador que queremos entre los registros que hemos extraído:

FUNCIÓN PARA EXTRAER REGISTROS ÚNICOS DE UN RANGO

El resultado es este:

FUNCIÓN PARA EXTRAER REGISTROS ÚNICOS DE UN RANGO_1.jpg

Como podéis observar, la función nos ofrece el resultado esperado y en un tiempo razonable. Si necesitáramos pasar los datos a un rango os recomiendo la funcionalidad texto en columnas, en la función no se puede realizar (solo aplicando la función matricialmente, y para eso lo podemos lograr con una fórmula).

Y eso es todo, espero que os resulte de utilidad.

Descarga el archivo de ejemplo pulsando en: FUNCIÓN PARA EXTRAER REGISTROS ÚNICOS DE 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!!

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

SELECCIONAR ARCHIVOS DE UNA CARPETA Y ENVIARLOS POR OUTLOOK SEGÚN EL NOMBRE DE LA CARPETA

Hola a todos!:

Parece que este 2019 ya se va apagando poco a poco!. Y en breve estaremos iniciando el 2020. Espero que todo nos vaya muy bien y se cumplan nuestros sueños y proyecto.

Mientras tanto, voy a escribir un post como respuesta a una consulta:

Hola Segu, una duda, necesito hacer estos envios, pero en lugar de tener el nombre de los aduntos, lo que tengo es el nombre de las carpetas. Mi macro debe recorrer esos nombres, ir abriendo cada carpeta y adjuntando para cada persona todos los archivos que contengan esas rutas.

Es decir, para el destinatario “MANUEL” tengo que ir a la carpeta en ruta que se llame Manuel y enviar en un correo todos los archivos contenidos en esa ruta..

No consigo que me adjunte los archivos..

¿Puedes ayudarme? Gracias

Esta consulta viene como referencia a un post inicial en el que programé un procedimiento automático de envío de archivos según los tengamos detallados en nuestra hoja Excel. Este es el post: SELECCIONAR ARCHIVOS DE UNA CARPETA Y ENVIARLOS POR OUTLOOK SEGÚN CATÁLOGO DE INFORMES

En este caso, lo que el lector solicita es que el código recorra todas las carpetas y cuando se encuentra con las que hemos indicado, adjunte en para cada nombre/carpeta todo el contenido de la misma en el correo de outlook.

Vamos a aprovechar la macro del proceso anterior y modificar algunas rutinas para realice lo que necesitamos:

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

Function CARPETA(ByVal nCarpeta)
'Declaramos variables
Dim olApp As Outlook.Application
Dim olMail As Outlook.MailItem
Dim fin As Long, i As Long, File As Variant
Dim adjunto As String, nFile As String
Dim olMailItem As Variant, Celda As Variant
'Iniciamos función
With Sheets("Hoja1")
fin = Application.CountA(.Range("A:A"))
'recorremos hoja y celda para comprobar si hace
'referencia a varios archivos.
Set olApp = CreateObject("Outlook.Application")
Set olMail = olApp.CreateItem(olMailItem)
'Recorremos todas las carpetas y subcarpetas
For Each subcarpeta In nCarpeta.SubFolders
CARPETA subcarpeta
Next subcarpeta
For i = 2 To fin
'Si la carpeta se llama igual a la que tenemos en la hoja
'Adjuntamos todo su contenido
If .Cells(i, 1) = nCarpeta.Name Then
For Each File In nCarpeta.Files
adjunto = File
nFile = Left(File.Name, InStr(File.Name, ".") - 1)
'Destinatario
olMail.To = .Cells(i, 2)
'Con copia a
olMail.CC = .Cells(i, 3)
'Con copia oculta
olMail.BCC = .Cells(i, 4)
'Asunto
olMail.Subject = .Cells(i, 1)
'Cuerpo de correo
olMail.HTMLBody = "Buenos días:
Les enviamos los archivos solicitados.
Atentamente."
' Adjuntamos archivo y dejamos correo en bandeja de salida
olMail.Attachments.Add (adjunto)
'Para enviar debéis utilizar Send en lugar de Display
'olMail.Send
olMail.Display
Next File
End If
Next i
olMail: Close
olApp: Close
End With
Set olMail = Nothing
Set olApp = Nothing
End Function

A diferencia del post anterior, en este caso vamos a recorrer todas las carpetas y subcarpetas hasta encontrar la que coincida con la hemos especificado en la hoja. En el momento que lo haga adjuntaremos todos los archivos a Outlook.

Por ejemplo, si elijo uno de mis post (donde guardo todos los archivos con los que escribo la entrada, imágenes, excel, etc):

SELECCIONAR ARCHIVOS DE UNA CARPETA Y ENVIARLOS POR OUTLOOK SEGÚN EL NOMBRE DE LA CARPETA

Y esta sería la carpeta:

SELECCIONAR ARCHIVOS DE UNA CARPETA Y ENVIARLOS POR OUTLOOK SEGÚN EL NOMBRE DE LA CARPETA_1

Con un total de 6 archivos que tendríamos que adjuntar. Si ejecutamos la macro y seleccionamos la carpeta en la que se encuentran los datos, generaremos el siguiente email:

SELECCIONAR ARCHIVOS DE UNA CARPETA Y ENVIARLOS POR OUTLOOK SEGÚN EL NOMBRE DE LA CARPETA_2

Como podéis observar, aquí tenemos el correo con todos los adjuntos de la carpeta que hemos indicado.

Y esta ha sido la contestación a la consulta, espero que también a vosotros os sea de utilidad para vuestros procedimientos de envío.

Descarga el archivo de ejemplo pulsando en: SELECCIONAR ARCHIVOS DE UNA CARPETA Y ENVIARLOS POR OUTLOOK SEGÚN EL NOMBRE DE LA CARPETA

¿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

GENERAR UN PATRÓN NUMÉRICO CON MATRICES BIDIMENSIONALES EN VBA

Hola a todos!.

Espero que estéis pasando unos buenos días de descanso durante este puente de la Constitución!.

Hoy ha decidido escribir un pequeño post sobre los patrones numéricos y una forma de generar uno en particular. Se trata del siguiente (aunque puede tener muchas variaciones): 123 212 321 o lo que es lo mismo pero visualmente en Excel:

GENERAR UN PATRÓN NUMÉRICO CON MATRICES BIDIMENSIONALES EN VBA

Podéis verlo perfectamente, y además me he permitido utilizar el formato condicional para colorear el área, generando así una secuencia mucho más visual, fijaros en el número 1, (verde) cómo se repita y cruza la diagonal. Esto lo podremos hacer de distintos tamaños, por ejemplo, de 20X20:

GENERAR UN PATRÓN NUMÉRICO CON MATRICES BIDIMENSIONALES EN VBA_1

Y ¿cómo generamos este patrón?, aquí el código:

Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'Declaramos variables
Dim Mensaje As String, Titulo As String, MiArea As Variant
Dim i As Long, j As Long, celda As String
'Con un inputbox determinamos las dimensiones de nuestro cubo
Mensaje = "Introduce un número que será el alto y ancho del cubo que vamos a crear, por ejemplo el 20 para ser 20X20"
Titulo = "AREA DEL CUBO"
MiArea = InputBox(Mensaje, Titulo)
If StrPtr(MiArea) = 0 Then Exit Sub
'Mediante dos bucles anidados generamos una matriz de dos dimensiones
'que realizará la inversión de los dígitos generados en la primera columna
ReDim MiRango(0 To MiArea, 0 To MiArea)
MiRango(0, 0) = 1
For i = 1 To MiArea
MiRango(i, 0) = MiRango(i - 1, 0) + 1
MiRango(0, i) = MiRango(0, i - 1) + 1
For j = 1 To MiArea
MiRango(i, j) = MiRango(i - 1, j - 1)
MiRango(j, i) = MiRango(j - 1, i - 1)
Next j
Next i
'Pasamos los datos desde la celda activa con dobleclick
celda = ActiveCell.Address
Range(celda).Resize(MiArea, MiArea).Value = MiRango
End Sub

Como podéis observar utilizamos una matriz de dos dimensiones (necesaria) para crear esta secuencia, dado que necesitamos tener en cuenta filas y columnas. Las matrices se rellenan mediante dos loop anidados e incrementando +1 en cada fila y columna.

Podemos modificarlos y multiplicarlo por 2, por 3 etc o hacerlo en las diagonales (j) y el patrón sería distinto.

Para que no tengáis que ir modificando el área del cubo, os he creado en la macro un inputbox para indicarlo antes de pasar los datos a la hoja.

Y esto es todo, este es un ejercicio para que veais no solo cómo se puede crear este patrón, sino como podemos rellenar y generar una matriz bidimensional y (importate), pasarla a la hoja.

Descarga el archivo de ejemplo pulsando en: GENERAR UN PATRÓN NUMÉRICO CON MATRICES BIDIMENSIONALES 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!!

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

OBTENER CÓDIGO RGB DE LA PALETA DE COLORES DE EXCEL CON VBA

Hola a todos:

En principio este fin de semana no tenía pensado escribir ningún post, he estado bastante liado con temas personales y realmente el viernes me encontraba agotado y con ganas de descansar.

Pero hoy estoy un poco más libre y tengo una hora suelta para escribir un post. Hoy os quiero mostrar una forma de obtener el código RGB de cualquier color que forme parte de la paleta de colores de Excel.

Hace unas semanas escribí una entrada sobre cómo GENERAR PALETA DE COLORES CON VBA  era un ejercicio muy sencillo que tenía como objetivo el poder generar la paleta de colores, y además el de modificar un loop para recorrer determinado rango de filas y columnas.

Hoy voy a tratar de completar aquel trabajo inicial con unas líneas de código que nos servirán para mostrar el RGB.

En rojo están los cambios fundamentales.

'Option Explicit
Sub PALETA_COLOR()
'Definimos variables
Dim CONT As Integer, COL As Integer, i As Integer, Control As String
Dim Rojo As String, Verde As String, Azul As String
'Inicializamos proceso
CONT = 1
COL = 1
'Creamos loop para colorear celda con cada color index
'Cada 6 celdas seguimos el loop en la columna siguiente
For i = 1 To 56
If CONT <= 5 Then
'Aplicamos color
Cells(CONT, COL).Interior.ColorIndex = i
'Obtenemos RGB
Control = WorksheetFunction.Rept("0", 6 - Len(Hex(Cells(CONT, COL).Interior.Color))) & Hex(Cells(CONT, COL).Interior.Color)
Rojo = Application.WorksheetFunction.Hex2Dec(Right(Control, 2))
Verde = Application.WorksheetFunction.Hex2Dec(Mid(Control, 3, 2))
Azul = Application.WorksheetFunction.Hex2Dec(Left(Control, 2))
Cells(CONT, COL).Value = Rojo & "|" & Verde & "|" & Azul
Cells(CONT, COL + 1).Value = "Color: " & i
CONT = CONT + 1
Else
'Aplicamos color
Cells(CONT, COL).Interior.ColorIndex = i
'Obtenemos RGB
Control = WorksheetFunction.Rept("0", 6 - Len(Hex(Cells(CONT, COL).Interior.Color))) & Hex(Cells(CONT, COL).Interior.Color)
Rojo = Application.WorksheetFunction.Hex2Dec(Right(Control, 2))
Verde = Application.WorksheetFunction.Hex2Dec(Mid(Control, 3, 2))
Azul = Application.WorksheetFunction.Hex2Dec(Left(Control, 2))
Cells(CONT, COL).Value = Rojo & "|" & Verde & "|" & Azul
Cells(CONT, COL + 1).Value = "Color: " & i
CONT = 1
COL = COL + 2
End If
Next i
End Sub

Lo que hacemos en cada una de las variables en las que almacenamos el número del color es:

En primer lugar pasar el número que se obtiene Interior.Color a la función Hex con la obtendremos una string representando su valor Hexagesimal. Y que debe contener 6 posiciones, con 0 hasta llegar al final.

WorksheetFunction.Rept("0", 6 - Len(Hex(Cells(CONT, COL).Interior.Color))) & Hex(Cells(CONT, COL).Interior.Color)

A continuación, por cada color extraemos parte del código que vamos a pasar a Dec con la función Hex2Dec

Ese valor será parte de los tres colores para componer nuestro código RGB.

El resultado es:

OBTENER CODIGO RGB DE LA PALETA DE COLORES DE EXCEL

Y eso es todo, espero que os sea de utilidad!!

Descarga el archivo de ejemplo pulsando en: OBTENER CÓDIGO RGB DE LA PALETA DE COLORES 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!!

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