VBA - Localizar nomes com cores iguais e Agrupar

[Diogo Valentim]

Prezados,

 

Estou precisando de uma grande ajuda em programação de uma macro.

 

Tenho a seguinte necessidade: Uma tabela contem diversos nomes de pessoas. Estes nomes estão em Preto e Negrito.

Logo abaixo de cada nome existe uma repetição do mesmo nome em azul.

 

Os nomes pretos são totalizadores, enquanto os nomes em Azul são os dados unitários.

Pois bem, meu chefe gosta de usar o agrupador de dados, ( DADOS>AGRUPAR), e precisava agrupar todos os nomes de cor azul.

 

João 3 João 3 Maria 2 Maria 2 Jorge 11 Jorge 2 Jorge 4 Jorge 5 Pedro 14 Pedro 6 Pedro 5 Pedro 1 Pedro 2

 

A idéa da Macro é a seguinte:

 

Na coluna A existem os Dados.

 

Selecione os nomes igual a João em Azul e Agrupe

Selecione os nomes Maria em Azul e Agrupe

Etc...

 

 

Localizei a cor via VBA:

 

If Cell.Font.Color = -65536 Then

 

Só não estou conseguindo pensar em uma forma de selecionar nomes iguais.

 

Podem me ajudar?

 

 

 

[Wendell Menezes]

Olá,

 

Pode postar a sua planilha ou um exemplo similar para trabalharmos nela?

 

Obrigado

[Diogo Valentim]

Desculpem pela falta de Exemplo.

Segue em anexo.

 

Na aba exemplo está os dados de exemplo.

Na aba resultado que desejo, está a forma como deve estar agrupado após a macro rodar.

 

Obrigado!

Exemplo.xlsx

[Wendell Menezes]

Olá,

 

Experimente esse código:

Sub Group()Dim Color As Long, r As Long, x As LongColor = 16711680For r = 2 To Cells(Rows.Count, 1).End(xlUp).Row    If Cells(r, 1).Font.Color = Color And Cells(r - 1, 1).Font.Color = 0 Then x = r    If Cells(r, 1).Font.Color = Color And Cells(r + 1, 1).Font.Color = 0 Then        Rows(x & ":" & r).Group    End IfNextEnd Sub

Abraço

[Diogo Valentim]

Muito obrigado Wendell!

 

Só esqueci de citar um problema que muda um pouco as coisas.

As cores Azul e Preto são definidos por uma formatação condicional.

 

Segue planilha com exemplo modificado.

 

Me desculpe, só lembrei deste erro em VBAs depois de sua solução, que percebi não funcionar 

Exemplo.xlsx

[Wendell Menezes]

Olá Nocte,

 

Não tenho certeza se o código abaixo funciona em versões anterioriores ao Excel 2010, mas deu acerto na minha máquina:

Sub Group()Dim Color As Long, r As Long, x As LongColor = 13369344For r = 2 To Cells(Rows.Count, 1).End(xlUp).Row    If Cells(r, 1).DisplayFormat.Font.Color = Color And Cells(r - 1, 1).DisplayFormat.Font.Color = 0 Then x = r    If Cells(r, 1).DisplayFormat.Font.Color = Color And Cells(r + 1, 1).DisplayFormat.Font.Color = 0 Then        Rows(x & ":" & r).Group    End IfNextEnd Sub

Caso não funcione sugiro que nos diga exatamente qual é o critério aplicado na sua planilha para formatar a cor da fonte.

 

Com base no seu seu segundo exemplo o código ficaria assim:

Sub Group_2()Dim r As Long, x As LongFor r = 2 To Cells(Rows.Count, 1).End(xlUp).Row    If Cells(r, 3) = "s" And Cells(r - 1, 3) = "" Then x = r    If Cells(r, 3) = "s" And Cells(r + 1, 3) = "" Then        Rows(x & ":" & r).Group    End IfNextEnd Sub

Abraço

[Diogo Valentim]

Caro Wendell,

 

Eu adaptei seu código para que funcionasse em minha planilha.

Mas respondendo a seu grande ajuda, a formatação condicional que passei é exatamente a mesma.

Não posso passar a planilha por ser sigilosa.

Eu estava lendo que a formatação condicional muda a forma como algumas linhas de comando devem se comportar.

Estou usando o Office 2013.

 

o "s" que usei na formatação condicional que enviei foi só uma forma de mostrar como usei a formatação.

No caso nas celulas que continham o "s", apareceria números correspondentes a um procv trazendo números distintos.

 

Nesse caso adaptei o

If Cells(r, 3) = "s"

para:

For r = 2 To Cells(Rows.Count, 1).End(xlUp).RowIf Cells(r, 1).DisplayFormat.Font.Color = Color And Cells(r - 1, 1) = "" Then x = rIf Cells(r, 1).DisplayFormat.Font.Color = Color And Cells(r + 1, 1) = "" ThenRows(x & ":" & r).GroupEnd IfNext

 

Estou ainda fazendo algumas adaptações.

Caso em um dia não consiga resolver sozinho, posto novamente uma resposta.

 

Realmente meu caro, ajuda demais!!!!!!!

Ótima noite e muito obrigado por emprestar seu cérebro!