¿Cómo diseñar Macro para colorear filas por coincidencias?

Para todos y complacido de poder participar con mi inquietud y ojalá me puedan ayudar. Lo cierto es que soy novato (muy novato) y estoy en una carrera contra el tiempo que no me permite dedicarle mucho tiempo. Es por ello que acudo a pedir ayuda. Y no se trata de pereza, es que necesito una solución rápido. Aparte que ya no soy ningún joven, y la mente no es la misma, y aunque en la Uni programé mucho, ya esos conocimientos se me olvidaron y ni me sirven de base.

Mi problema es el siguiente:

Tengo unas base de datos con cientos de miles de filas por 6 columnas. Lo que necesito es una Macro que me busque fila por fila si las celdas C, D, E y F que (ojalá pudiera escoger y hasta colocar criterios de búsqueda, p. Ej, que este en blanco alguna de ellas) ; le corresponde, coinciden con otra (Cn=Cm, Dn=Dm, En=Em y Fm=Fn) y de ser así tanto esta como la coincidente se coloreen (en rojo por ejemplo. Con la primeras 2 celdas bastaría para advertirme la duplicidad). Yo se que existen las coincidencias porque al buscar las celdas repetidas seleccionando estas 4 columnas, me arroja que si hay pero las borra. Yo quiero que queden señaladas, no que las borre. De eso se trata.

Una rutina para colorear la copié de aquí pero es evidente que no me funciona, lo mas que he logrado que no sirve para nada, es que me repita del primer grupo de la lista todos los datos en una sola celda, pero de colorear nada. Creo que es porque debo quitar comentarios y colocar valores. Pues ahí por mis conocimientos tan limitados no lo logró por mas que ensaye. Igual seguiré tratando mientras consigo ayuda.

Muchas gracias y espero me puedan ayudar.

Esta es la rutina que copié:

Sub EncadenaColumnas(r As Range)
'encadena los vlores de cada fila en la siguiente columna
Dim i As Integer
Dim j As Integer
Dim maxi As Integer 'máximo numero de filas
Dim maxj As Integer ' máximo numero de columnas
Dim es As String
maxi = r.Rows.Count
maxj = r.Columns.Count
For i = 1 To maxi
es = ""
For j = 1 To maxj
es = es & Cells(i, j).Value
Next j
Cells(i, maxj + 1).Value = es 'copio el valor en la columna siguiente
Next i
End Sub
Sub ColoreaDuplicadosColumna(c As Range, micolor As Integer)
'c debe ser una columna
Dim i As Integer
Dim j As Integer
Dim por As Integer
Dim maxi As Integer 'máximo numero de filas
j = c.Column
maxi = c.Rows.Count
For i = 1 To maxi
For por = i + 1 To maxi
If Cells(i, j).Value = Cells(por, j).Value Then
'coloreo la primera
Cells(i, j).Interior.ColorIndex = micolor
End If
Next por
Next i
End Sub
Sub BorraFilasColoreadas(c As Range, micolor As Integer)
Dim i As Integer
Dim j As Integer
Dim maxi As Integer 'máximo numero de filas
j = c.Column
maxi = c.Rows.Count
For i = maxi To 1 Step -1 'en orden inverso
If Cells(i, j).Interior.ColorIndex = micolor Then
Rows(i).Select
Selection.Interior.ColorIndex = micolor
'Selection.Delete Shift:=xlUp 'descomentar para borrar
End If
Next i
End Sub
Sub ColoreaBorraFilasDuplicadas()
Dim r As Range
Dim c As Range
Set r = Range("A1:F871")
Set c = Range("G1:G871")
Call EncadenaColumnas(r)
Call ColoreaDuplicadosColumna(c, 3)
'Call BorraFilasColoreadas(c, 3) 'descomentar para que se ejecute
End Sub

1 respuesta

Respuesta
1

Me cuesta un poco entenderte, pero según el código que has puesto veo que lo que quieres es una macro que marque de color las filas repetidas de un rango. Te pongo una macro que utiliza los filtros de Excel, va filtrando con los valores de cada fila (una por una) y coloreando las filas que coincidan de un color aleatorio para que cada grupo de filas repetidas tengan un color diferente.

Sub ColorearRepetidos2()
    Application.ScreenUpdating = False
    Dim Rango As Excel.Range
    Dim Columnas As Integer
    Dim Formula As String
    Dim i As Integer
    Dim j As Integer
    Set Rango = Selection
    For i = 1 To Rango.Rows.Count
        If Rango.Resize(1).Offset(i - 1).Interior.Color = RGB(255, 255, 255) Then
            For j = 1 To Rango.Columns.Count
                Rango.AutoFilter j, "=" & Rango.Resize(1, 1).Offset(i - 1, j - 1).Value
            Next
            If Rango.SpecialCells(xlCellTypeVisible).Count > 2 * Rango.Columns.Count Then
                Rango.SpecialCells(xlCellTypeVisible).Interior.Color = RGB(Int((200 * Rnd) + 1), Int((200 * Rnd) + 1), Int((200 * Rnd) + 1))
            End If
            For j = 1 To Rango.Columns.Count
                Rango.AutoFilter j
            Next
        End If
    Next
    Rango.AutoFilter
    Rango.Resize(1).Interior.Pattern = none
End Sub

Para usar la macro debes poner títulos de columna a los datos y debes seleccionar los títulos de columna junto con los datos para que la macro funcione bien.

No es precisamente un rango diría yo, pero puede que igual estemos hablando de los mismo, lo trataré de ilustrar con un ejemplo simple:

A B C D E F G

1 O L H T P R Y

2 L N W H J S A

3 A M H T P R F

4 D X G E P U V

En el ejemplo la primera fila y la tercera tienen cuatro de sus valores iguales (H,T,P,R), pues yo quisiera que Excel me consiguiera todas las que tuvieran esas coincidencias y las resaltara (alguna celda por lo menos), no que las borrara. Que en el caso ahora cuando utilizo la herramienta "Quitar duplicados" (Datos) el las busca las encuentra y las borra. Yo quisiera que en vez de borrarlas las señalara. Es como una cambio de instrucción. En esta herramienta yo le escojo que use como criterio de coincidencia la columna C, D, E y F que son las que me interesa saber si se repiten de esta manera.

Pues nada seleccione toda la tabla que tiene encabezado (sin incluirlo en la selección) y me da error por desbordamiento. Error 6 en tiempo de ejecución.

Ok, la macro que te pase compara todas las columnas(A, B, C, D, E, F, G), para que solo te compare las que quieras hay que hacer una modificación

Sub ColorearRepetidos2()
    Application.ScreenUpdating = False
    Dim Rango As Excel.Range    
    Dim ColumnasRepetidas As String
    Dim Columnas As variant
    Dim Formula As String
    Dim i As Integer
    Dim j As Integer
    Set Rango = Selection
    ColumnasRepetidas="1,2,3,4,5,6,7"
    Columnas=split(ColumnasRepetidas[color=#008800],","[/color])
    For i = 1 To Rango.Rows.Count
        If Rango.Resize(1).Offset(i - 1).Interior.Color = RGB(255, 255, 255) Then
            For j = 1 To ubound(Columnas)
                Rango.AutoFilter Columnas(j), "=" & Rango.Resize(1, 1).Offset(i - 1, val(Columnas(j)) - 1).Value
            Next
            If Rango.SpecialCells(xlCellTypeVisible).Count > 2 * Rango.Columns.Count Then
                Rango.SpecialCells(xlCellTypeVisible).Interior.Color = RGB(Int((200 * Rnd) + 1), Int((200 * Rnd) + 1), Int((200 * Rnd) + 1))
            End If
            For j = 1 To Rango.Columns.Count
                Rango.AutoFilter j
            Next
        End If
    Next
    Rango.AutoFilter
    Rango.Resize(1).Interior.Pattern = none
End Sub

Fijate de esta linea ColumnasRepetidas="1,2,3,4,5,6,7" Ahí pones las columnas que vas a revisar, en el ejemplo que pusiste pondrías algo como ColumnasRepetidas="3,4,5,6" y de esa forma se marcarían de color la primera y la tercera fila.

Nota que tendrías que agregar un encabezado a tus datos y quedarían semejante a

A B C D E F G
1 Col1 Col2 Col3 Col4 Col5 Col6 Col7

2 O L H T P R Y
2 L N W H J S A
3 A M H T P R F
4 D X G E P U V

Los datos tiene encabezado. Lo que se es que al seleccionar toda la lista antes de ejuctare la Macro el queda por fuera no?. Le coloque Columnas repetidas="3,4,5,6", que son las que ahora quiero comparar, pero igual me arroja: Error 6 en tiempo de ejecución > DESBORDAMIENTO. Al depurar me aparece que está en: For i = 1 To Rango.Rows.Count

Sub ColorearRepetidos3()     On Error Resume Next '    Application.ScreenUpdating = False     Dim Rango As Excel.Range     Dim Columnas As Variant     Dim Formula As String     Dim i As Double     Dim j As Double     Set Rango = Selection     Columnas = Split("3,4,5,6", ",")     For i = 1 To Rango.Rows.Count         If Rango.Resize(1).Offset(i - 1).Interior.Color = RGB(255, 255, 255) Then             For j = 1 To UBound(Columnas)                 Rango.AutoFilter Columnas(j), "=" & Rango.Resize(1, 1).Offset(i - 1, Val(Columnas(j)) - 1).Value             Next             Err.Clear             If Rango.SpecialCells(xlCellTypeVisible).Count > 2 * Rango.Columns.Count Then '                 If Err.Description = "" Then                     Rango.SpecialCells(xlCellTypeVisible).Interior.Color = RGB(Int((200 * Rnd) + 1), Int((200 * Rnd) + 1), Int((200 * Rnd) + 1))                 End If             End If             For j = 1 To Rango.Columns.Count                 Rango.AutoFilter j             Next         End If     Next     Rango.AutoFilter     Rango.Resize(1).Interior.Pattern = noneEnd Sub

Esta macro debe funcionar, ya agregue control de errores, y cambie el tipo de datos de Integer a Double, el error que te sale era porque el Integer no soporta cientos de miles, el Double si.

Recuerda que si debes incluir los encabezados de columna en la selección.

Vuelvo a mostrar la macro, en la respuesta anterior apareció en una sola linea

Sub ColorearRepetidos3()
    On Error Resume Next '
    Application.ScreenUpdating = False
    Dim Rango As Excel.Range
    Dim Columnas As Variant
    Dim Formula As String
    Dim i As Double
    Dim j As Double
    Set Rango = Selection
    Columnas = Split("3,4,5,6", ",")
    For i = 1 To Rango.Rows.Count
        If Rango.Resize(1).Offset(i - 1).Interior.Color = RGB(255, 255, 255) Then
            For j = 1 To UBound(Columnas)
                Rango.AutoFilter Columnas(j), "=" & Rango.Resize(1, 1).Offset(i - 1, Val(Columnas(j)) - 1).Value
            Next
            Err.Clear
            If Rango.SpecialCells(xlCellTypeVisible).Count > 2 * Rango.Columns.Count Then '
                If Err.Description = "" Then
                    Rango.SpecialCells(xlCellTypeVisible).Interior.Color = RGB(Int((200 * Rnd) + 1), Int((200 * Rnd) + 1), Int((200 * Rnd) + 1))
                End If
            End If
            For j = 1 To Rango.Columns.Count
                Rango.AutoFilter j
            Next
       End If
    Next
    Rango.AutoFilter
    Rango.Resize(1).Interior.Pattern = none
End Sub

Estuvo unos 10 mins. trabajando pero ahora ya tiene congelado 5 mins. el Excel sin poder hacer mas que mover el mouse..

Que maravilla !!. Trate con una parte pequeña de la tabla y los coroleo perfecto en cuatro diferentes colores pero por lo que parece con los 100tos de miles es demasiado y se tranca. Supongo que solo es un detalle no?

Agrega esta linea al final de la macro justo después de Rango.Resize(1).Interior.Pattern = none

Application.ScreenUpdating = False

Esto es para que no se quede congelada la pantalla, pero ten en cuenta que cientos de miles de filas no es poca cosa y si se va a llevar su tiempo.

Ahora si quieres rapidez tengo esta otra macro pero esta utiliza el Formato Condicional de Excel, es mas rapido pero con la desventaja que te marca las filas del mismo color (rojo)

Sub ColorearRepetidos()
    Dim Rango As Excel.Range  
    Dim Formula As String
    Dim Columnas As Variant
    Dim i As Double
    Set Rango = Selection
    Columnas = Split("3,4,5,6", ",")
    Formula = "= SUMAPRODUCTO((" & Rango.Cells(1, 1).Address(0, 0) & "<>"""")"
    For i = LBound(Columnas) To UBound(Columnas)
        Formula = Formula & "*(" & Rango.Cells(1, Val(Columnas(i))).Address(0, 1) & "=" & Rango.Resize(, 1).Offset(0, Val(Columnas(i)) - 1).Address & ")"
    Next
    Formula = Formula & ")>1"
    Rango.FormatConditions.Delete
    Rango.FormatConditions.Add Type:=xlExpression, Formula1:=Formula
    Rango.FormatConditions(1).Interior.Color = RGB(255, 0, 0)
End Sub

En este no necesitas seleccionar los encabezados. Recuerda poner las columnas a revisar en esta linea Columnas = Split("3,4,5,6", ",")

Deja ver como corre la que me pinta solo en rojo. Luego me tocaría ordenar para ver las coincidencias pero no es gran cosa. Esta ejecutándose ahora. Yo se bien que debo esperar por el trabajo que esto implica para la máquina, tranquilo, lo que ocurre es que se colgó y en administrador de tareas según parecía no estaba trabajando. Haría falta un visor para ver el desarrollo ;). Ya infromo que resulto !!

Se volvió a trancar. Lo deje todo este tiempo mientras salí a dar una vuelta, y esta congelado. Para que tengas una mayor idea la tabla con la que trabajo ahora es de 7 columnas con 113.247 filas.

Prueba hacerlo de forma manual. Modificando un poco la macro para que te de la formula que debes poner en el Formato Condicional de Excel. Así sabrás si es el Excel que no puede procesar tanta información.

Sub ColorearRepetidos()
Dim Rango As Excel.Range
Dim Formula As String
Dim Columnas As Variant
Dim i As Double
Set Rango = Selection
Columnas = Split("3,4,5,6", ",")
Formula = "= SUMAPRODUCTO((" & Rango.Cells(1, 1).Address(0, 0) & "<>"""")"
For i = LBound(Columnas) To UBound(Columnas)
Formula = Formula & "*(" & Rango.Cells(1, Val(Columnas(i))).Address(0, 1) & "=" & Rango.Resize(, 1).Offset(0, Val(Columnas(i)) - 1).Address & ")"
Next
Formula = Formula & ")>1"
InputBox "Formula para Formato Condicional", "Formula", Formula
End Sub

Te debe mostrar una Formula, Cópiala

Después Selecciona el rango de tus datos

Clic en Inicio

Clic en Formato Condicional

Clic en Nueva Regla

Clic en Utilice una formula que determine las celdas para aplicar el formato

Pega la Formula que genero la macro

Clic en el botón Formato

Clic en la pestaña Relleno

Selecciona un color

Clic en Aceptar

Clic en Aceptar

Si se traba otra vez entonces es que Excel es el que se esta tardando, y tienes que ir haciendolo poco a poco.

Ahora coloque solo 2000 filas y noto que trabaja porque se van pintando de rojo algunas y sube y baja. Ya lleva como 10 mins. Si es cierto que solo he visto rojo ningún otro color, ya que estoy utilizando la que colocaste para que coloque distinto color que me funciono perfecto con unos poquitos.

La otra que solo que pinta en rojo la probé con 1000 filas, pero aunque trabajo rapidísimo solo no se si me borro los repetidos porque quedaron como 200 todos sin pintar. Y serian muchos. Porque en esa que te dije completa hay casi 6000 repetidos bajo ese criterio.

Se volvió a trabar, rarísimo, funciona pero por ejemplo no puedo ver mas abajo de lo que se ve en pantalla, si bajo la flecha se devuelve, como si estuviera aun trabajando, será?. Y fue con solo 2000. No tengo nada mas trabajando. El rendimiento lo tengo alto así que no debería ser hardware sino que pareciera que es demasiado para el Excel. Si aguantara de 50.000 en 50.000 me las arreglaría poco a poco pero de 1.000 en 1.000 seria demasiado cuesta arriba.

Las macro que pinta de varios colores filtra filas, es decir oculta las que no corresponden al criterio, probablemente lo que paso fue que interrumpiste la macro cuando tenia filtrado(ocultado) las filas. Solo selecciona el rango de tus datos y has clic en la pestaña Inicio de Excel y clic en la opción Ordenar y Filtrar has clic en la opción Filtro y se deben quitar los filtros que puso la macro que pinta de varios colores.

Fijate lo ocurrió con los últimos 2.000. Hice lo que me dijiste con quitar los filtors y la verdad es que trabajo pero igual no podía ver mas abajo de los filas que tenia en pantalla. No hubo manera y apague la PC. La prendí, abrí el archivo con los 2.000 registros y me apareció uno con solo 83. No están resaltados. Y si hay algunos que cumplen la condición. Por decirte como 10.

¿Cuál macro estas utilizando? La macro que colorea de rojo no debería ocultar filas, ¿puedes adjuntar el archivo?

Dices que no puedes ver mas allá de las filas que están en pantalla, esto puede ser porque esta habilitado la opción de inmovilizar paneles, revísalo haciendo clic en la pestaña Vista de Excel y luego clic en la opción Inmovilizar y verifica que ninguna de las tres opciones este habilitada.

Pues voy a volver a probar pero las que aparecen como repetidas en esas pocas que quedaron no son duplicados como tal sino copias. Probé a bucar la dulpicidad y salen una sola vez. Esos no son.

Pues nada. Aparentemente solo funcionó con una centena de filas. Pero luego para arriba no funciona. Muchas gracias por el intento. Pero no resultó por lo que veo. En Access no habrá una mejor manera?

Buenos días Experto !

Acabo de probar este código con solo 100 filas y encontró dos registros que los coloreo pero coinciden en la columna 4,5,6 mas no en la 3, sabes que está ocurriendo?, sera esa una de las razones del porque trabaja tanto, busca con 4 y luego con 3?, que entiendo que debería seguir con 2..1..0..y luego negativos, pero en este ensayo no lo hizo:

Sub ColorearRepetidos3()
On Error Resume Next '
Application.ScreenUpdating = False
Dim Rango As Excel.Range
Dim Columnas As Variant
Dim Formula As String
Dim i As Double
Dim j As Double
Set Rango = Selection
Columnas = Split("3,4,5,6", ",")
For i = 1 To Rango.Rows.Count
If Rango.Resize(1).Offset(i - 1).Interior.Color = RGB(255, 255, 255) Then
For j = 1 To UBound(Columnas)
Rango.AutoFilter Columnas(j), "=" & Rango.Resize(1, 1).Offset(i - 1, Val(Columnas(j)) - 1).Value
Next
Err.Clear
If Rango.SpecialCells(xlCellTypeVisible).Count > 2 * Rango.Columns.Count Then '
If Err.Description = "" Then
Rango.SpecialCells(xlCellTypeVisible).Interior.Color = RGB(Int((200 * Rnd) + 1), Int((200 * Rnd) + 1), Int((200 * Rnd) + 1))
End If
End If
For j = 1 To Rango.Columns.Count
Rango.AutoFilter j
Next
End If
Next
Rango.AutoFilter
Rango.Resize(1).Interior.Pattern = none
End Sub

Eso es todo amigo. Lo probé con 1500 filas y lo que ocurre es que está seleccionando también las que tienen tres coincidencias. Si hay algunos duplicados con 4 coincidencias, pero de los colores por un lado ayuda pero hay algunos que son tan oscuros que no se ve. Aunque si arrojara solo de 4 coincidencias igual ayudaría mucho mas.

Es entonces solo cuestión de evitar que haga esto. Claro esta que yo no so capaz, por lo menos ahora no lo veo posible. Si pudieras terminar de ayudarme, te lo agradecería. Es una lastima quedarse aquí habiendo cubierto el 75%.

Prueba con esta macro

Sub ColorearRepetidos5()
On Error Resume Next
Application.ScreenUpdating = False
Dim Rango As Excel.Range
Dim Datos As Variant
Dim DatosFaltantes() As Variant
Dim DatosFaltantes2() As Variant
Dim Columnas As Variant
Dim Igual As Boolean
Dim Repetidos As Boolean
Dim i As Double
Dim j As Double
Dim que As Double
Dim color As Double
Dim Tiempo As Double
Dim TiempoInicio As Date
Dim CeldaFilaComparar As Excel.Range
Dim FilaInicio As Double
Tiempo = 1
Set CeldaFilaComparar = ActiveSheet.Range("AA1")
Set Rango = Selection
TiempoInicio = Now
Datos = Rango
Columnas = Split("3,4,5,6", ",")
If Val(CeldaFilaComparar) = 0 Then
FilaInicio = LBound(Datos)
Else
FilaInicio = Val(CeldaFilaComparar)
End If
For i = FilaInicio To UBound(Datos)
If Rango.Cells(i, 1).Interior.color = 16777215 Then
Repetidos = False
For j = i + 1 To UBound(Datos)
For k = LBound(Columnas) To UBound(Columnas)
Igual = True
If Datos(i, Val(Columnas(k))) <> Datos(j, Val(Columnas(k))) Then
Igual = False
End If
Next
If Igual = True Then
Repetidos = True
color = RGB(Int((200 * Rnd) + 1), Int((200 * Rnd) + 1), Int((200 * Rnd) + 1))
Rango.Resize(1).Offset(j - 1).Interior.color = color
End If
Next
If Repetidos = True Then
Rango.Resize(1).Offset(i - 1).Interior.color = color
End If
If DateAdd("n", Tiempo, TiempoInicio) < Now Then
CeldaFilaComparar = i + 1
Exit Sub
End If
End If
Next
Application.ScreenUpdating = True
End Sub

En donde dice Set CeldaFilaComparar = ActiveSheet.Range("AA1") escribe la celda donde se guardara la fila en que se quedo la macro, yo tengo puesto la celda "AA1", cuando vuelvas a ejecutar la macro comenzara desde la fila que esté en esta celda.
En donde dice Tiempo = 1 escribe el tiempo en minutos que quieres que se ejecute la macro, yo tengo puesto 1 minuto, después de ese tiempo la macro se detendrá y guardara la fila donde se quedo para que cuando la vuelvas a ejecutar comience donde se quedo.
En donde dice Columnas = Split("3,4,5,6", ",") como en las otras macros pones las columnas en las que quieres encontrar coincidencias.
Esta macro no oculta filas, ni las elimina ni nada, solo pinta las celdas repetidas, no deberías tener problemas con ella.
Siento no poderte ayudar mas.

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas