Fóruns
Microsoft Excel - 2...
2024 - VBA & Macros
VBA Para Retirar Nú...
 
Notifications
Clear all

VBA Para Retirar Número de Uma Celúla

 
2024 - VBA & Macros
Post Recente por psm 7 anos atrás
5 Posts
4 Usuários
0 Reactions
3,391 Visualizações
RSS
 JPrado
(@jprado)
Posts: 8
Active Member
Topic starter
 

Pessoal, boa tarde.

Preciso de uma fórmula, macro ou vba para extrair número de uma determinada célula, porém está célula não segue as mesmas quantidades de caracteres.

Abaixo tem uns exemplos dos textos, nas duas primeiras linhas eu preciso do número do Docto e nas duas últimas preciso do número após o IR.

E301 10:64159-FORNECEDOR Docto 3665 de FAMECCANICA DATA SPA
E349:64169-COFINS IMPORTACAO Docto 3662 de DIVERSIFIED SUPPLY
DOC 00018678 2 SECRETARIA DA RECEITA FEDERAL IR 0016/16
DOC 00018679 SECRETARIA DA RECEITA FEDERAL IR 0018/16

Achei na internet uma VBA porém ela só funciona na planilha que salvei, nas demais não funciona.

Abri um arquivo no Excel, colei a VBA e salvei na area de trabalho como Planilha Habilitada para Macros do Microsoft Excel.

Alguém consegui me ajudar, saber o que fiz de errado ou só funciona em Excel anterior a versão que uso, atualmente tenho a 2016

Obrigadoo.

Abaixo a VBA:

Private Sub Worksheet_Change(ByVal Target As Range)

Public Function lfRetiraNumeros(ByVal vValor As String) As String
    
    Application.Volatile
 
    Dim vQtdeCaract As Long
    Dim vControle   As Boolean
 
    vQtdeCaract = Len(vValor)
    vControle = False
 
    
    For i = 1 To vQtdeCaract
        
        If IsNumeric(Mid(vValor, i, 1)) Then
            If vControle = True And lfRetiraNumeros <> vbNullString Then
                lfRetiraNumeros = lfRetiraNumeros + " "
            End If
            vControle = False
            lfRetiraNumeros = lfRetiraNumeros & Mid(vValor, i, 1)
        Else
            vControle = True
        End If
    Next
 
    
    lfRetiraNumeros = Replace(Trim(lfRetiraNumeros), " ", "/")
 
End Function
 
Postado : 12/05/2016 2:52 pm
 Osvaldomp
(@osvaldomp)
Posts: 858
Prominent Member
 

Olá.

Se quiser experimentar via fórmula.

Considerando os seus dados a partir da célula 'A1', cole a fórmula abaixo em 'B1' e arraste para baixo.

=SE(ÉNÚM(PROCURAR("Docto";A1));EXT.TEXTO(A1;PROCURAR("Docto";A1)+6;4);EXT.TEXTO(A1;PROCURAR("IR";A1)+3;7))

Osvaldo

 
Postado : 12/05/2016 3:35 pm
 psm
(@psm)
Posts: 2
New Member
 

Olá.... Como seria esse código com a função inversa, ou seja, extraindo somente texto? Encontrei essa função abaixo, mas, diferentemente da outra essa que encontrei não to conseguindo fazer dela uma macro que capture a seleção do usuário.

Public Function lfExtrairCaracteres(vPesquisa As Range) As String
Dim lQtde As Long

Application.Volatile

'Recebe o valor da célula
lfExtrairCaracteres = vPesquisa.Text

'Retira os caracteres de 0 a 9, trocando-os por ""
For lQtde = 0 To 9
lfExtrairCaracteres = Replace(lfExtrairCaracteres, lQtde, "", 1)
Next lQtde

End Function

=============== Aí tentei o código abaixo para funcionar em um intervalo selecionado, mas, não tá dando certo ============

Sub extrair_caracter()
For Each c In Selection

On Error Resume Next 'Se a função utizada em células que não contenham caracteres, o erro será ignorado
Let c.Value = lfExtrairCaracteres(c.Value)

Next
End Sub

 
Postado : 21/03/2018 7:29 am
Fernando Fernandes
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

O ideal era ter aberto seu próprio tópico, e não utilizar um tópico antigo e com objetivo diferente.
Contudo experimente:

Public Function lfExtrairCaracteres(vPesquisa As String) As String 'Alterado de range para string
Dim lQtde As Long
Application.Volatile
'Recebe o valor da célula
lfExtrairCaracteres = vPesquisa
'Retira os caracteres de 0 a 9, trocando-os por ""
For lQtde = 0 To 9
    lfExtrairCaracteres = Replace(lfExtrairCaracteres, lQtde, "", 1)
Next lQtde
End Function

Sub extrair_caracter()
For Each c In Selection
On Error Resume Next 'Se a função utizada em células que não contenham caracteres, o erro será ignorado
c.Value = lfExtrairCaracteres(c.Value) 
Next
End Sub

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

 
Postado : 21/03/2018 8:07 am
 psm
(@psm)
Posts: 2
New Member
 

Reinaldo, obrigado pelo retorno. Deu certinho aqui...

Desculpe pela utilização do tópico existente, pois, foi a minha primeira atividade no site. Mas, deve ajudar as pessoas tirar as duas dúvidas de uma vez só..rs..rs

Agradeço,

Pablo Moreira

 
Postado : 21/03/2018 10:48 am
Forum Jump:
  Tópico Anterior
Próximo Tópico