VBA – Somar por Cor

A função a seguir calcula o valor total de todas as células em um determinado intervalo que são de uma determinada cor:

Infelizmente, não existe uma função SUMIF para somar com base na cor da célula. Se quiser fazer a soma por cor, você precisará criar uma função no VBA.
Para usar esse código: Abra o Editor do Visual Basic (Alt + F11), insira um novo módulo (Inserir > Modulo) e copie e cole o código desejado no módulo.

Função para Somar por Cor

Function Somar_Por_Cor(Intervalo As Range, Indice_Cor As Integer) As Double

Dim Celula

'Analisará as células que estão no intervalo e, se
'a propriedade cor interior corresponder à cor da célula solicitada
'então, ela será somada

'Fazer um loop pelo intervalo

For Each Celula In Intervalo

   If (Celula.Interior.ColorIndex = Indice_Cor) Then
      Somar_Por_Cor = Somar_Por_Cor + Celula.Value
   End If

Next Celula

End Function

Se você conhece a paleta de 56 cores do Excel e sabe, por exemplo, que a cor 4 é verde-claro, então a seguinte chamada:

Somar_Por_Cor(“A1:P20”,4)

somará os valores de todas as células do intervalo A1:P20 que são de cor verde-clara.

Para facilitar o uso da função, a seguinte sub-rotina calculará o valor total de cada uma das 56 cores do Excel. Ela também fornece a paleta inteira para que seja fácil ver o número de índice de cada cor.

A sub-rotina é chamada na planilha 1 e examina o intervalo.

Private Sub ComandoBotao1_Click()

'Analisará cada cor e produzirá uma tabela resumida de valores
'na planilha 1, na célula A1 e de baixo para cima

Dim Numero_Cor_Atual As Integer
Dim Cor_Total As Double

For Numero_Cor_Atual = 1 To 56

   Cor_Total = Somar_Por_Cor(Sheets("Planilha2").Range("a11:aa64"), Numero_Cor_Atual)

   Worksheets("Planilha1").Range("A1").Offset(Numero_Cor_Atual, 0) = Numero_Cor_Atual
   Worksheets("Planilha1").Range("A1").Offset(Numero_Cor_Atual, 0).Interior.ColorIndex = Numero_Cor_Atual

   If Cor_Total 0# Then
      Worksheets("Planilha1").Range("a1").Offset(Numero_Cor_Atual, 1).Value = Cor_Total
   End If

Next Numero_Cor_Atual

End Sub

Para fazer download do arquivo XLS, clique aqui

<<Retornar aos exemplos de VBA