Extrair eMails

|Blog Office VBA | Blog Excel | Blog Access | Blog Infochart | 

DESENVOLVO APLICAÇÕES VBA

O que é o fenômeno chamado BIG DATA?

Acesse uma ENORME lista de Dashboards e Infográficos

Aprenda a detectar gráficos que precisam mudar

Dados ou Informações?

Dashboards - 8 Importantes características desejáveis

Dashboards e Infocharts - Diversas Visualizações de Dados

Diversos exemplos de Gráficos

Excel - DashMap - Mapa do Brasil

Key Performance Indicators - 7 Características desejáveis

MIS - Usufruindo a excelência na análise das suas Informações

O Melhor do Business Intelligence

Os 10 mandamentos do gerenciamento de projetos

Receba  3 Calendários Customizáveis de  2013 em Excel

Usando Gauges em Dashboards no MS Access

Consegue extrair um endereço de eMail de uma linha onde estejam contidos outros dados?

Veja o exemplo: 

André Luiz Bernardes <bernardess@gmail.com>

Utilize a função ExtractEmailAddress para extrair somente o endereço do e-mail.

Function ExtractEmailAddress(s As String) As String

    ' Author:                     Date:               Contact:

    ' André Bernardes             11/08/2008 09:01    bernardess@gmail.com

    ' Extrai apenas o e-mail de uma célula.

    Dim AtSignLocation As Long

    Dim i As Long

    Dim TempStr As String

    Const CharList As String = "[A-Za-z0-9._-]"

    'Localizando a @.

    Let AtSignLocation = InStr(s, "@")

    If AtSignLocation = 0 Then

        Let ExtractEmailAddress = "" 'not found

    Else

        Let TempStr = ""

        'Parte do e-mail antes da @.

        For i = AtSignLocation - 1 To 1 Step -1

            If Mid(s, i, 1) Like CharList Then

                Let TempStr = Mid(s, i, 1) & TempStr

            Else

                Exit For

            End If

        Next i

        If TempStr = "" Then Exit Function

        'Parte do e-mail depois da @.

        Let TempStr = TempStr & "@"

        For i = AtSignLocation + 1 To Len(s)

            If Mid(s, i, 1) Like CharList Then

                Let TempStr = TempStr & Mid(s, i, 1)

            Else

                Exit For

            End If

        Next i

    End If

    'Remove trailing period if it exists

    If Right(TempStr, 1) = "." Then _

       Let TempStr = Left(TempStr, Len(TempStr) - 1)

    Let ExtractEmailAddress = TempStr

End Function

Tags: VBA, Tips, UDF, e-mail, eMail,