Excel Apenas colorir parte do texto na mesma célula

[Sandra Vasquez]

Bom dia,

 

Eu já tentei criar uma formatação no VBA para colorir apenas parte do texto da célula , mas não está funcionando muito bem

 

Tem um tópico parecido aqui no fórum   , mas o que eu preciso acredito ser um pouco diferente, mas com o mesmo conceito.

 

Exemplo:  tem alguns padrões de texto especifico na mesma célula , que gostaria de colorir.

 

Coluna A , Range 1 a 40

 

Texto a colorir:  Tubo1 ; Tubo2 ; Tubo3  até Tubo40     Cor Verde

                         Caixa1; Caixa2; Caixa3 até Caixa40  Cor Amarelo

                         pacote1;pacote2 até pacote40            Cor Azul

 

Enfim, exemplo:

 

Coluna A célula na linha 1 texto na mesma célula : Tubo 1 Caixa 2  Pacote 3 ( pintar (tubo1) verde ; pintar (tCaixa2) amarelo ;pintar (pacote3 ) azul)

Coluna A célula na linha 2 texto na mesma célula : Tubo 5 Caixa 10  Pacote 30 ( pintar (tubo5) verde ; pintar (Caixa10) amarelo ;pintar (pacote30) azul)

Enfim , da coluna A range de 1 a 40 , pintar conforme o texto especifico , e caso não contenha nenhum desses texto , não pintar.

                      

 

Alguém consegue me ajudar?

[Charley Rocha]

Bom dia! Achei esse link na internet, acho que resolve seu problema:

 

https://stackoverflow.com/questions/30567552/change-font-color-for-a-part-of-text-in-cell

[Visitante]

 

Experimente:

 

 

Sub PintaFonte()
 Dim k As Long, v As Long, c As Range
  For Each c In Range("A1:A" & Cells(Rows.Count, 1).End(3).Row)
   k = InStr(1, c.Value, "Tubo")
   If k > 0 Then
    v = InStr(k + 5, c.Value, " ")
     c.Characters(k, v - k).Font.Color = vbGreen
   End If
   k = InStr(1, c.Value, "Caixa")
   If k > 0 Then
    v = InStr(k + 6, c.Value, " ")
     c.Characters(k, v - k).Font.Color = vbRed 'vbYellow
   End If
   k = InStr(1, c.Value, "Pacote")
   If k > 0 Then
    v = InStr(k + 7, c.Value, " ")
     c.Characters(k, v - k).Font.Color = vbBlue
   End If
  Next c
End Sub

 

[Edson Luiz Branco]

Bem vinda ao fórum, @Sandra Vasquez

 

Aqui vai mais uma:

Option Compare Text
Sub PintarTexto()
 Dim cél As Range, m As Object
 With CreateObject("VBScript.RegExp")
   .Pattern = "((Tubo|Caixa|Pacote)\s*\d+)": .IgnoreCase = True: .Global = True: .MultiLine = True
   For Each cél In [A1:A40].Cells
     For Each m In .Execute(cél.Value)
       cél.Characters(m.FirstIndex + 1, m.Length).Font.Color = Switch(m.SubMatches(1) = "Tubo", vbGreen, _
                                                                      m.SubMatches(1) = "Caixa", vbYellow, _
                                                                      m.SubMatches(1) = "Pacote", vbBlue)
     Next m
   Next cél
 End With
End Sub

Obs.: O código intercepta a ocorrência de algum dos textos-chave (Tubo/Caixa/Pacote) seguidos ou não de espaço(s) em branco e seguidos de pelo menos um algarismo. Se o padrão for outro, nos avise, ok?

[Sandra Vasquez]

8 minutos atrás, Edson Luiz Branco disse:

Bem vinda ao fórum, @Sandra Vasquez

 

Obs.: O código intercepta a ocorrência de algum dos textos-chave (Tubo/Caixa/Pacote) seguidos ou não de espaço(s) em branco e seguidos de pelo menos um algarismo. Se o padrão for outro, nos avise, ok?

 

Nossa , já testei seu código , muito bom , curto , mais eficaz, e eu rachando a cabeça aqui , obrigada mesmo.

adicionado 3 minutos depois

1 hora atrás, osvaldomp disse:

 

Experimente:

 

 

 

O código do Edson funcionou , mas mesmo assim vou testar o seu também viu.

 

Agradeço muito , pela rapidez da resposta , não sabia que era tão rápido assim , achei que ia demorar uma vida para solucionar meu problema kkk

[Sandra Vasquez]

Em 27/02/2020 às 11:00, Edson Luiz Branco disse:

Bem vinda ao fórum, @Sandra Vasquez

 

Aqui vai mais uma:

Obs.: O código intercepta a ocorrência de algum dos textos-chave (Tubo/Caixa/Pacote) seguidos ou não de espaço(s) em branco e seguidos de pelo menos um algarismo. Se o padrão for outro, nos avise, ok?

 

Edson, seu código está funcionando perfeitamente , mas na minha planilha eu uso concatenar para puxar esses dados para minha coluna , e quando executo seu código , acaba pintando tudo na mesma cor , exemplo se na célula usando concatenar aparece tudo e caixa , ele pinta tudo da mesma cor , ai testei colocar os textos em usar concatenar , ai funciona , mas se usar o concatenar , pinta tudo na mesma cor , tem como acertar isso ? porque tem muitos dados, e preciso puxar com concatenar  , se puder ajudar , agradeço. obrigada

[Edson Luiz Branco]

Sandra, anexe aqui um arquivo com alguns exemplos disso, pois fica mais fácil trabalhar direto em cima de seu modelo.

Obs.: se for .xlsm tem que zipar pra poder anexar aqui no fórum.

[Sandra Vasquez]

22 horas atrás, Edson Luiz Branco disse:

Sandra, anexe aqui um arquivo com alguns exemplos disso, pois fica mais fácil trabalhar direto em cima de seu modelo.

Obs.: se for .xlsm tem que zipar pra poder anexar aqui no fórum.

Fiz um exemplo , demorei porque estou tento problemas o excel agora começou a dar aviso de compartilhamento , e apaga minha planilhas e o windows não estava deixando eu zipar nenhuma pasta com macro .

Pasta1.rar

[Edson Luiz Branco]

Ok, Sandra, entendi.

 

Mas infelizmente não é possível mudar individualmente a cor de caracteres quando oriundos de resultado de alguma fórmula naquela célula: ou muda tudo ou nada.

 

A boa notícia é que há várias formas de conseguir o mesmo resultado via VBA. Um deles seria você fazer a concatenação não via fórmula mas direto no código.

 

A outra, mais imediata, é destruir a fórmula de concatenação ficando só com o valor dela na célula, aí seria só inserir uma instrução no código que te passei acima (ou também poderia ser com Copiar/Colar Valores) :

Sub PintarTexto()
 Dim cél As Range, m As Object
 With CreateObject("VBScript.RegExp")
   .Pattern = "((Tubo|Caixa|Pacote)\s*\d+)": .IgnoreCase = True: .Global = True: .MultiLine = True
   For Each cél In [A1:A40].Cells
     cél.Value = cél.Value '<====Insira essa instrução
     For Each m In .Execute(cél.Value)
       cél.Characters(m.FirstIndex + 1, m.Length).Font.Color = Switch(m.SubMatches(1) = "Tubo", vbGreen, _
                                                                      m.SubMatches(1) = "Caixa", vbYellow, _
                                                                      m.SubMatches(1) = "Pacote", vbBlue)
     Next m
   Next cél
 End With
End Sub

 

De qualquer maneira, você só obterá o efeito desejado quando não houver fórmula na célula.

[Sandra Vasquez]

2 horas atrás, Edson Luiz Branco disse:

Ok, Sandra, entendi.

 

Mas infelizmente não é possível mudar individualmente a cor de caracteres quando oriundos de resultado de alguma fórmula naquela célula: ou muda tudo ou nada.

 

A boa notícia é que há várias formas de conseguir o mesmo resultado via VBA. Um deles seria você fazer a concatenação não via fórmula mas direto no código.

 

A outra, mais imediata, é destruir a fórmula de concatenação ficando só com o valor dela na célula, aí seria só inserir uma instrução no código que te passei acima (ou também poderia ser com Copiar/Colar Valores) :

 

De qualquer maneira, você só obterá o efeito desejado quando não houver fórmula na célula.

 

Obrigado Edson.