Fóruns
Microsoft Excel - 2...
2024 - VBA & Macros
Extrair texto de cé...
 
Notifications
Clear all

Extrair texto de célula alfanumérica

 
2024 - VBA & Macros
Post Recente por celsoyano 11 anos atrás
3 Posts
2 Usuários
0 Reactions
1,784 Visualizações
RSS
 celsoyano
(@celsoyano)
Posts: 75
Estimable Member
Topic starter
 

Boa tarde,

Desculpe ao moderadores se estou postando em seção errada.
Fiquei na dúvida se postava aqui na seção de VBA ou na de Funções. Como é uma função personalizada resolvi postar aqui.

Bom, eu achei um código na internet que cria a função "RetiraNúmeros" que ela separa os números de uma célula que tenha caracteres alfanuméricos:

A1 = "CEL123SO"
B1 = "=ReticaNumeros(A1) o resultado na célula B1 é "123"

O código dessa fórmula está logo abaixo.

O que eu queria era um função que extraísse o texto, exemplos:
CEL123SO, "Resultado = CELSO"
1ALEX, "Resultado = ALEX"
J25ULIO, "Resultado = JULIO"
RICAR999DO, "Resultado = RICARDO"

'<alteracao>
'Esta função tem por objetivo retirar números de células que contenham conteúdos mistos de números e texto
'sem a possibilidade de serem colunados
Public Function RetiraTextos(ByVal vValor As String) As String
    'Atualiza o cálculo automaticamente
    Application.Volatile
 
    'Conta a quantidade de caracteres
    Dim vQtdeCaract As Long
    Dim vControle   As Boolean
 
    vQtdeCaract = Len(vValor)
    vControle = False
 
    'Para cada caractere identifica se é número ou texto
    For i = 1 To vQtdeCaract
        'Se for número adiciona no retorno da função
        If Application.IsText(Mid(vValor, i, 1)) = True Then
            If vControle = True And RetiraTextos <> vbNullString Then
                RetiraTextos = RetiraTextos + " "
            End If
            vControle = False
            RetiraTextos = RetiraTextos & Mid(vValor, i, 1)
        Else
            vControle = True
        End If
    Next
 
    'Substitui espaços em branco por / e tira espaços em branco no final do retorno da função
    RetiraTextos = Replace(Trim(RetiraTextos), " ", "/")
 
End Function
'</alteracao>
 
Postado : 28/03/2014 3:27 pm
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

Tente as Functions abaixo:

Somente o Texto:

Function ExtractText(stdText As String)
    Dim str As String, i As Integer
    stdText = Trim(stdText)
    
    For i = 1 To Len(stdText)
    
        If Not IsNumeric(Mid(stdText, i, 1)) Then
            str = str & Mid(stdText, i, 1)
        End If
    Next i
    
    ExtractText = str
    
End Function

Somente os Numeros:

Function ExtractNumber(rng As Range)

Dim i As Integer
    For i = 1 To Len(rng)
    
        Select Case Asc(Mid(rng.Value, i, 1))
            Case 0 To 64, 123 To 197
            ExtractNumber = ExtractNumber & Mid(rng.Value, i, 1)
        
        End Select
    
    Next i
    
End Function

Fonte: http://osdir.com/ml/excel-macros/2011-10/msg00282.html

[]s

 
Postado : 28/03/2014 4:15 pm
 celsoyano
(@celsoyano)
Posts: 75
Estimable Member
Topic starter
 

Deu certinho Mauro.

Obrigado

 
Postado : 29/03/2014 5:51 am
Forum Jump:
  Tópico Anterior
Próximo Tópico