Como contar celdas de colores distintos
Tengo la siguiente tabla en excel, lo que deseo es contar, que aparezca 3, celdas de color amarillo
2, por que hay 2 rojas y finalmente 2, por las ultimas dos celdas que son de color amarillo gracias
4 respuestas
Para contar celdas por su color de relleno, siempre y cuando no provenga de "Formato Condicional", una opción es usar una UDF. Abre el editor de VBA (VBE) e inserta un módulo "standard" y pega lo siguiente:
Function CONTARFONDO(Rango1 As Range, Rango2 As Range) As Long Application.Volatile True Dim Celda As Range Dim dblcontando& Let dblcontando = 0 For Each Celda In Rango1.Cells If Celda.Interior.ColorIndex = Rango2.Interior.ColorIndex Then Let dblcontando = dblcontando + 1 End If Next Celda Let CONTARFONDO = dblcontando End Function
Luego, vamos a suponer que en tu rango "A1:A20" tienes las celdas con diferentes colores de fondo en el que algunas coinciden. Supongamos que quieres contar todas las que tiene el mismo color de fondo que la celda "A3", entonces colocas así en, por ejemplo, tu celda "B1":
=CONTARFONDO(A1:A20,A3)
Y el resultado será, como ya mencioné, el número total de celdas cuyo fondo es igual a "A3" (incluyendo A3).
Abraham Valencia
Fernando Ramirez,
Adjunto en enlace el archivo excel con tu consulta desarrollada, Se utilizo macros para poder realizar la cuenta y mostrarla en una columna, además se adiciono un botón para limpiar la columna en donde se guardo las cantidades por color.
Sin otro particular, espero te sirva de ayuda.
Cualquier consulta estaré pendiente.
¡Gracias!
tengo problema para abrir excel
tengo versio 2007
Fernando Ramirez,
Vuelvo a enviar archivo para su revisión. Este si lo debes abrir, se guardo como versión 97 -2003.
Sin otro particular, estaré atento a cualquier consulta.
supongo que quieres algo asi?
Prueba esta macro, lo unico que tienes que hacer es marcar el area coloreada con el mouse o bien teclear asi: c3:c9 y la macro hara el resto
Sub cuenta_colores()
Dim unicos As New Collection
Set funcion = WorksheetFunction
On Error Resume Next
Set rango = Application.InputBox(prompt:="entra el area coloreada", Type:=8)
If Err.Number > 0 Then MsgBox ("tecle o señale con el mouse el area coloreada"), vbCritical, "AVISO": En d
On Error GoTo 0
With rango
r = .Columns(2).Address
.Cells(1, 2) = 1
.Cells(1, 2).AutoFill Destination:=Range(r), Type:=xlFillSeries
x = 1
For Each Celda In rango
xcolor = Celda.Interior.ColorIndex
.Cells(x, 3) = xcolor
On Error Resume Next
unicos.Add xcolor, CStr(xcolor)
On Error GoTo 0
x = x + 1
Next Celda
Set rango = .CurrentRegion
.Sort key1:=Range(.Columns(3).Address), order1:=xlAscending
For i = 1 To unicos.Count
xcolor = unicos.Item(i)
cuenta = funcion.CountIf(rango.Columns(3), xcolor)
fila = funcion.Match(xcolor, .Columns(3), 0)
Set area = .Rows(fila).Resize(cuenta, 1)
r = area.Columns(1).Address
area.Cells(1, 1) = 1
area.Cells(1, 1).AutoFill Destination:=Range(r), Type:=xlFillSeries
Next i
.Sort key1:=Range(.Columns(2).Address), order1:=xlAscending
.Columns(2).Resize(.Rows.Count, 2).Clear
End With
Set rango = Nothing
End Sub