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,794 Visualizações

RSS

celsoyano

(@celsoyano)

Posts: 75

Trusted 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

Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel

Postado : 28/03/2014 4:15 pm